gopro-plus (empty) → 0.1.0.0
raw patch · 10 files changed
+861/−0 lines, 10 filesdep +HUnitdep +aesondep +basesetup-changed
Dependencies added: HUnit, aeson, base, bytestring, containers, exceptions, filepath, generic-deriving, gopro-plus, lens, lens-aeson, mtl, random, retry, tasty, tasty-hunit, tasty-quickcheck, text, time, transformers, unix, unliftio, unordered-containers, vector, wreq
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +6/−0
- Setup.hs +2/−0
- gopro-plus.cabal +100/−0
- src/GoPro/Plus/Auth.hs +68/−0
- src/GoPro/Plus/Internal/HTTP.hs +45/−0
- src/GoPro/Plus/Media.hs +292/−0
- src/GoPro/Plus/Upload.hs +304/−0
- test/Spec.hs +11/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for gopro-plus++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Dustin Sallings (c) 2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Dustin Sallings nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,6 @@+# gopro-plus++Interface to GoPro Plus cloud service.++This is not meant to be a stable interface, it mostly just fell out of+an application I'm writing.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ gopro-plus.cabal view
@@ -0,0 +1,100 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: b4c60409c9e9406365ffe3ec82ce27b60c07ebd5d0034067010866c7ef456fbd++name: gopro-plus+version: 0.1.0.0+synopsis: GoPro Plus Client API.+description: Please see the README on GitHub at <https://github.com/dustin/gopro-plus#readme>+category: Web+homepage: https://github.com/dustin/gopro-plus#readme+bug-reports: https://github.com/dustin/gopro-plus/issues+author: Dustin Sallings+maintainer: dustin@spy.net+copyright: MIT+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/dustin/gopro-plus++library+ exposed-modules:+ GoPro.Plus.Auth+ GoPro.Plus.Internal.HTTP+ GoPro.Plus.Media+ GoPro.Plus.Upload+ other-modules:+ Paths_gopro_plus+ hs-source-dirs:+ src+ default-extensions: OverloadedStrings RecordWildCards NamedFieldPuns+ ghc-options: -Wall+ build-depends:+ aeson+ , base >=4.7 && <5+ , bytestring+ , containers+ , exceptions+ , filepath+ , generic-deriving+ , lens+ , lens-aeson+ , mtl+ , random+ , retry+ , text+ , time+ , transformers+ , unix+ , unliftio+ , unordered-containers+ , vector+ , wreq+ default-language: Haskell2010++test-suite gopro-plus-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_gopro_plus+ hs-source-dirs:+ test+ default-extensions: OverloadedStrings RecordWildCards NamedFieldPuns+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ HUnit+ , aeson+ , base >=4.7 && <5+ , bytestring+ , containers+ , exceptions+ , filepath+ , generic-deriving+ , gopro-plus+ , lens+ , lens-aeson+ , mtl+ , random+ , retry+ , tasty+ , tasty-hunit+ , tasty-quickcheck+ , text+ , time+ , transformers+ , unix+ , unliftio+ , unordered-containers+ , vector+ , wreq+ default-language: Haskell2010
+ src/GoPro/Plus/Auth.hs view
@@ -0,0 +1,68 @@+{-|+Module : GoPro.Plus.Auth+Description : Functionality for authenticating to GoPro Plus.+Copyright : (c) Dustin Sallings, 2020+License : BSD3+Maintainer : dustin@spy.net+Stability : experimental++GoPro Plus authentication.+-}++{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module GoPro.Plus.Auth (+ authenticate, refreshAuth,+ AuthResponse(..), access_token, expires_in, refresh_token, resource_owner_id+ ) where++import Control.Lens+import Control.Monad.IO.Class (MonadIO (..))+import Data.Aeson (FromJSON (..), genericParseJSON)+import Generics.Deriving.Base (Generic)+import Network.Wreq (FormParam (..))+++import GoPro.Plus.Internal.HTTP++apiClientID, apiClientSecret :: String+apiClientID = "71611e67ea968cfacf45e2b6936c81156fcf5dbe553a2bf2d342da1562d05f46"+apiClientSecret = "3863c9b438c07b82f39ab3eeeef9c24fefa50c6856253e3f1d37e0e3b1ead68d"++authURL :: String+authURL = "https://api.gopro.com/v1/oauth2/token"++-- | An Authentication response.+data AuthResponse = AuthResponse {+ _access_token :: String+ , _expires_in :: Int+ , _refresh_token :: String+ , _resource_owner_id :: String+ } deriving(Generic, Show)++instance FromJSON AuthResponse where+ parseJSON = genericParseJSON jsonOpts++makeLenses ''AuthResponse++authenticate :: MonadIO m+ => String -- ^ Email/username+ -> String -- ^ Password+ -> m AuthResponse+authenticate username password =+ jpostWith defOpts authURL ["grant_type" := ("password" :: String),+ "client_id" := apiClientID,+ "client_secret" := apiClientSecret,+ "scope" := ("root root:channels public me upload media_library_beta live" :: String),+ "username" := username,+ "password" := password]++-- | Refresh authentication credentials using a refresh token.+refreshAuth :: MonadIO m => AuthResponse -> m AuthResponse+refreshAuth AuthResponse{..} =+ jpostWith defOpts authURL ["grant_type" := ("refresh_token" :: String),+ "client_id" := apiClientID,+ "client_secret" := apiClientSecret,+ "refresh_token" := _refresh_token]
+ src/GoPro/Plus/Internal/HTTP.hs view
@@ -0,0 +1,45 @@+module GoPro.Plus.Internal.HTTP where++import Control.Lens+import Control.Monad.IO.Class (MonadIO (..))+import Data.Aeson (FromJSON (..), Options (..),+ defaultOptions, fieldLabelModifier)+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as BL+import Network.Wreq (Options, asJSON, defaults, getWith,+ header, postWith, responseBody)+import Network.Wreq.Types (Postable)++userAgent :: BC.ByteString+userAgent = "github.com/dustin/gopro 0.1"++defOpts :: Network.Wreq.Options+defOpts = defaults & header "User-Agent" .~ [userAgent]+++authOpts :: String -> Network.Wreq.Options+authOpts tok = defOpts & header "Authorization" .~ ["Bearer " <> BC.pack tok]+ & header "Accept" .~ ["application/vnd.gopro.jk.media+json; version=2.0.0"]+ & header "Content-Type" .~ ["application/json"]++type Token = String++jsonOpts :: Data.Aeson.Options+jsonOpts = defaultOptions {+ fieldLabelModifier = dropWhile (== '_')+ }++-- | Proxy a request to GoPro with authentication.+proxy :: MonadIO m => Token -> String -> m BL.ByteString+proxy tok u = do+ r <- liftIO $ getWith (authOpts tok) u+ pure $ r ^. responseBody++jget :: (MonadIO m, FromJSON a) => Token -> String -> m a+jget tok = jgetWith (authOpts tok)++jgetWith :: (MonadIO m, FromJSON a) => Network.Wreq.Options -> String -> m a+jgetWith opts u = view responseBody <$> liftIO (getWith opts u >>= asJSON)++jpostWith :: (MonadIO m, Postable a, FromJSON r) => Network.Wreq.Options -> String -> a -> m r+jpostWith opts u v = view responseBody <$> liftIO (postWith opts u v >>= asJSON)
+ src/GoPro/Plus/Media.hs view
@@ -0,0 +1,292 @@+{-|+Module : GoPro.Plus.Media+Description : Functionality for managing media within GoPro Plus.+Copyright : (c) Dustin Sallings, 2020+License : BSD3+Maintainer : dustin@spy.net+Stability : experimental++GoPro Plus media client.+-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module GoPro.Plus.Media (+ -- * Accessing Data+ list, listAll, listWhile, medium,+ retrieve, delete,+ fetchThumbnail,+ -- * Data Types+ PageInfo(..), current_page, per_page, total_items, total_pages,+ MediumID,+ Medium(..), medium_id, medium_camera_model, medium_captured_at,+ medium_created_at, medium_file_size, medium_moments_count,+ medium_ready_to_view, medium_source_duration, medium_type,+ medium_token, medium_width, medium_height,+ Listing(..), media, pages,+ File(..), file_camera_position, file_height, file_width,+ file_item_number, file_orientation, file_url,+ Variation(..), var_height, var_width, var_label, var_quality,+ var_type, var_url,+ SpriteFrame(..), frame_count, frame_height, frame_width,+ Sprite(..), sprite_fps, sprite_frame, sprite_height, sprite_width,+ sprite_type, sprite_urls,+ FileStuff(..), files, variations, sprites, sidecar_files,+ FileInfo(..), fileStuff, filename,+ Error(..), error_reason, error_code, error_description, error_id,+ -- * Low-level Junk+ putRawMedium+ ) where++import Control.Lens+import Control.Monad.IO.Class (MonadIO (..))+import Data.Aeson (FromJSON (..), Options (..),+ ToJSON (..), Value (..),+ defaultOptions, fieldLabelModifier,+ genericParseJSON, genericToEncoding,+ genericToJSON, (.:))+import Data.Aeson.Types (typeMismatch)+import qualified Data.ByteString.Lazy as BL+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import Data.Time.Clock (UTCTime)+import qualified Data.Vector as V+import Generics.Deriving.Base (Generic)+import Network.Wreq (asJSON, deleteWith, putWith,+ responseBody)+import System.Random (getStdRandom, randomR)+++import GoPro.Plus.Internal.HTTP++data PageInfo = PageInfo {+ _current_page :: Int,+ _per_page :: Int,+ _total_items :: Int,+ _total_pages :: Int+ } deriving (Generic, Show)++makeLenses ''PageInfo++instance FromJSON PageInfo where+ parseJSON = genericParseJSON jsonOpts++type MediumID = T.Text++data Medium = Medium {+ _medium_id :: MediumID,+ _medium_camera_model :: Maybe String,+ _medium_captured_at :: UTCTime,+ _medium_created_at :: UTCTime,+ _medium_file_size :: Maybe Int,+ _medium_moments_count :: Int,+ _medium_ready_to_view :: String,+ _medium_source_duration :: Maybe String,+ _medium_type :: String,+ _medium_token :: String,+ _medium_width :: Maybe Int,+ _medium_height :: Maybe Int+ } deriving (Generic, Show)++makeLenses ''Medium++dropPrefix :: String -> (String -> String)+dropPrefix s = drop (length s)++mediumMod :: String -> String+mediumMod = dropPrefix "_medium_"++instance ToJSON Medium where+ toEncoding = genericToEncoding jsonOpts{ fieldLabelModifier = mediumMod}+ toJSON = genericToJSON jsonOpts{ fieldLabelModifier = mediumMod}++instance FromJSON Medium where+ parseJSON = genericParseJSON jsonOpts{ fieldLabelModifier = mediumMod}++-- | Get the thumbnail token for a given medium result.+thumbnailURL :: Int -> Medium -> String+thumbnailURL n Medium{_medium_token} = "https://images-0" <> show n <> ".gopro.com/resize/450wwp/" <> _medium_token++-- | Fetch thumbnail data for the given medium.+fetchThumbnail :: MonadIO m => Token -> Medium -> m BL.ByteString+fetchThumbnail tok m = do+ n <- liftIO $ getStdRandom (randomR (1,4))+ proxy tok (thumbnailURL n m)++data Listing = Listing {+ _media :: [Medium],+ _pages :: PageInfo+ } deriving (Generic, Show)++makeLenses ''Listing++instance FromJSON Listing where+ parseJSON (Object v) = do+ o <- v .: "_embedded"+ m <- o .: "media"+ ms <- traverse parseJSON (V.toList m)+ Listing ms <$> v .: "_pages"+ parseJSON invalid = typeMismatch "Response" invalid++-- | List a page worth of media.+list :: MonadIO m => Token -> Int -> Int -> m ([Medium], PageInfo)+list tok psize page = do+ r <- jget tok ("https://api.gopro.com/media/search?fields=captured_at,created_at,file_size,id,moments_count,ready_to_view,source_duration,type,token,width,height,camera_model&order_by=created_at&per_page=" <> show psize <> "&page=" <> show page)+ pure $ (r ^.. media . folded,+ r ^. pages)++-- | List all media.+listAll :: MonadIO m => Token -> m [Medium]+listAll tok = listWhile tok (const True)++-- | List all media while returned batches pass the given predicate.+listWhile :: MonadIO m => Token -> ([Medium] -> Bool) -> m [Medium]+listWhile tok f = do+ Map.elems <$> dig 0 mempty+ where+ dig n m = do+ (ms, _) <- list tok 100 n+ let m' = Map.union m . Map.fromList . map (\md@Medium{..} -> (_medium_id, md)) $ ms+ if (not . null) ms && f ms+ then dig (n + 1) m'+ else pure m'+++data File = File {+ _file_camera_position :: String,+ _file_height :: Int,+ _file_width :: Int,+ _file_item_number :: Int,+ _file_orientation :: Int,+ _file_url :: String+ } deriving (Generic, Show)++makeLenses ''File++instance FromJSON File where+ parseJSON = genericParseJSON defaultOptions {+ fieldLabelModifier = dropPrefix "_file_"+ }++data Variation = Variation {+ _var_height :: Int,+ _var_width :: Int,+ _var_label :: String,+ _var_quality :: String,+ _var_type :: String,+ _var_url :: String+ } deriving(Generic, Show)++makeLenses ''Variation++instance FromJSON Variation where+ parseJSON = genericParseJSON defaultOptions {+ fieldLabelModifier = dropPrefix "_var_"+ }++data SpriteFrame = SpriteFrame {+ _frame_count :: Int,+ _frame_height :: Int,+ _frame_width :: Int+ } deriving(Generic, Show)++makeLenses ''SpriteFrame++instance FromJSON SpriteFrame where+ parseJSON = genericParseJSON defaultOptions {+ fieldLabelModifier = dropPrefix "_frame_"+ }++data Sprite = Sprite {+ _sprite_fps :: Double,+ _sprite_frame :: SpriteFrame,+ _sprite_height :: Int,+ _sprite_width :: Int,+ _sprite_type :: String,+ _sprite_urls :: [String]+ } deriving (Generic, Show)++makeLenses ''Sprite++instance FromJSON Sprite where+ parseJSON = genericParseJSON defaultOptions {+ fieldLabelModifier = dropPrefix "_sprite_"+ }++data FileStuff = FileStuff {+ _files :: [File],+ _variations :: [Variation],+ _sprites :: [Sprite],+ _sidecar_files :: [Value]+ } deriving (Generic, Show)++makeLenses ''FileStuff++instance FromJSON FileStuff where+ parseJSON = genericParseJSON jsonOpts++data FileInfo = FileInfo {+ _fileStuff :: FileStuff,+ _filename :: String+ } deriving (Generic, Show)++makeLenses ''FileInfo++instance FromJSON FileInfo where+ parseJSON (Object v) = do+ o <- v .: "_embedded"+ fs <- parseJSON o+ FileInfo fs <$> v .: "filename"+ parseJSON invalid = typeMismatch "Response" invalid++dlURL :: String -> String+dlURL k = "https://api.gopro.com/media/" <> k <> "/download"++-- | Get download descriptors for a given medium. The format is+-- typically 'FileInfo', but it can be useful to map it into something+-- else.+retrieve :: (FromJSON j, MonadIO m) => Token -> String -> m j+retrieve tok k = jget tok (dlURL k)++data Error = Error {+ _error_reason :: String,+ _error_code :: Int,+ _error_description :: String,+ _error_id :: String+ } deriving (Generic, Show)++makeLenses ''Error++instance FromJSON Error where+ parseJSON = genericParseJSON defaultOptions {+ fieldLabelModifier = dropPrefix "_error_"+ }++newtype Errors = Errors [Error] deriving (Show)++instance FromJSON Errors where+ parseJSON (Object v) = do+ o <- v .: "_embedded"+ e <- o .: "errors"+ Errors <$> parseJSON e+ parseJSON invalid = typeMismatch "Response" invalid++-- | Delete an item.+delete :: MonadIO m => Token -> String -> m [Error]+delete tok k = do+ let u = "https://api.gopro.com/media?ids=" <> k+ Errors r <- view responseBody <$> liftIO (deleteWith (authOpts tok) u >>= asJSON)+ pure r++mediumURL :: String -> String+mediumURL = ("https://api.gopro.com/media/" <>)++-- | Get the current 'Medium' record for the given Medium ID.+medium :: (FromJSON j, MonadIO m) => Token -> MediumID -> m j+medium tok = jget tok . mediumURL . T.unpack++putRawMedium :: MonadIO m => Token -> String -> Value -> m Value+putRawMedium tok mid v = view responseBody <$> liftIO (putWith (authOpts tok) (mediumURL mid) v >>= asJSON)+
+ src/GoPro/Plus/Upload.hs view
@@ -0,0 +1,304 @@+{-|+Module : GoPro.Plus.Upload+Description : Functionality for uploading media to GoPro Plus.+Copyright : (c) Dustin Sallings, 2020+License : BSD3+Maintainer : dustin@spy.net+Stability : experimental++GoPro Plus media upload client.+-}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++module GoPro.Plus.Upload (+ -- * High level upload all-in-one convenience.+ uploadMedium,+ -- * Low-level upload parts.+ runUpload, resumeUpload,+ createMedium, createSource, createDerivative, createUpload,+ completeUpload, uploadChunk, markAvailable,+ -- * Data Types+ UID, UploadID, DerivativeID,+ UploadPart(..), uploadLength, uploadPart, uploadURL,+ Upload(..), uploadID, uploadParts,+ -- * Uploader monad.+ Uploader,+ setMediumType, setLogAction,+ -- * For your convenience.+ listUploading+ ) where++import Control.Applicative (liftA3)+import Control.Lens+import Control.Monad (void, when)+import Control.Monad.Catch (MonadMask (..))+import Control.Monad.Fail (MonadFail (..))+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.State (StateT (..), evalStateT, get, gets,+ lift, modify)+import Control.Retry (RetryStatus (..), exponentialBackoff,+ limitRetries, recoverAll)+import qualified Data.Aeson as J+import Data.Aeson.Lens+import qualified Data.ByteString.Lazy as BL+import Data.Char (toUpper)+import Data.Maybe (fromJust)+import qualified Data.Text as T+import Data.Time.Clock.POSIX (getCurrentTime)+import qualified Data.Vector as V+import Network.Wreq (Options, header, params, putWith)+import Prelude hiding (fail)+import System.FilePath.Posix (takeExtension, takeFileName)+import System.IO (IOMode (..), SeekMode (..), hSeek,+ withFile)+import System.Posix.Files (fileSize, getFileStatus)+import UnliftIO (MonadUnliftIO (..))++import GoPro.Plus.Internal.HTTP+import GoPro.Plus.Media (Medium (..), MediumID, list)++type UID = String+type UploadID = T.Text+type DerivativeID = T.Text++-- | GoPro Plus uploader monad.+type Uploader m = StateT (Env m) m++-- This is typically a bad idea, but we assume we only mutate state+-- before we'd ever need an unlift.+instance MonadUnliftIO m => MonadUnliftIO (StateT (Env m) m) where+ withRunInIO inner =+ get >>= \st -> StateT $ \_ ->+ withRunInIO $ \run -> (,st) <$> inner (run . flip evalStateT st)++data Env m = Env {+ token :: Token,+ userID :: UID,+ fileList :: [FilePath],+ mediumType :: T.Text,+ extension :: T.Text,+ filename :: String,+ mediumID :: MediumID,+ logAction :: (MonadMask m, Monad m) => String -> m ()+ }++-- | List all media in uploading state.+listUploading :: MonadIO m => Token -> m [Medium]+listUploading tok = do+ filter (\Medium{..} -> _medium_ready_to_view == "uploading") . fst <$> list tok 30 1++-- | Run an Uploader monad to create a single medium and upload the content for it.+runUpload :: (MonadFail m, MonadIO m)+ => Token -- ^ GoPro Plus authentication token.+ -> UID -- ^ GoPro Plus user ID.+ -> [FilePath] -- ^ The list of files to include in the medium.+ -> Uploader m a -- ^ The action to perform.+ -> m a -- ^ The result of the inner action.+runUpload token userID fileList a = resumeUpload token userID fileList "" a++-- | Run an Uploader monad for which we already know the MediumID+-- (i.e., we're resuming an upload we previously began).+resumeUpload :: (MonadFail m, MonadIO m) => Token -> UID -> [FilePath] -> MediumID -> Uploader m a -> m a+resumeUpload _ _ [] _ _ = fail "empty file list"+resumeUpload token userID fileList@(fp:_) mediumID a = evalStateT a Env{..}+ where+ extension = T.pack . fmap toUpper . drop 1 . takeExtension $ filename+ filename = takeFileName fp+ mediumType = fileType extension+ logAction _ = pure ()++ fileType "JPG" = "Photo"+ fileType _ = "Video"++-- | Override the detected medium type.+setMediumType :: Monad m => T.Text -> Uploader m ()+setMediumType t = modify (\m -> m{mediumType=t})++-- | Set the logging action to report retries (or whatever other+-- interesting things might happen).+setLogAction :: (Monad m, MonadMask m) => (String -> m ()) -> Uploader m ()+setLogAction t = modify (\m -> m{logAction=t})++jpostVal :: MonadIO m => Options -> String -> J.Value -> m J.Value+jpostVal opts u v = liftIO $ jpostWith opts u v++-- | Create a new medium (e.g., video, photo, etc...) and return its ID.+createMedium :: MonadIO m => Uploader m MediumID+createMedium = do+ Env{..} <- get+ let m1 = J.Object (mempty & at "file_extension" ?~ J.String extension+ & at "filename" ?~ J.String (T.pack filename)+ & at "type" ?~ J.String mediumType+ & at "on_public_profile" ?~ J.Bool False+ & at "content_title" ?~ J.String (T.pack filename)+ & at "content_source" ?~ J.String "web_media_library"+ & at "access_token" ?~ J.String (T.pack token)+ & at "gopro_user_id" ?~ J.String (T.pack userID))+ m <- fromJust . preview (key "id" . _String) <$> jpostVal (authOpts token) "https://api.gopro.com/media" m1+ modify (\s -> s{mediumID=m})+ pure m++-- | Convenient action for creating a Source derivative.+createSource :: MonadIO m => Int -> Uploader m DerivativeID+createSource nparts = createDerivative nparts "Source" "Source"++-- | Create a new derivative of the current medium containing the given number of parts.+createDerivative :: MonadIO m+ => Int -- ^ The number of parts this derivative contains.+ -> T.Text -- ^ The "type" of this derivative.+ -> T.Text -- ^ The label of this derivative.+ -> Uploader m DerivativeID+createDerivative nparts typ lbl = do+ Env{..} <- get+ let d1 = J.Object (mempty & at "medium_id" ?~ J.String mediumID+ & at "file_extension" ?~ J.String extension+ & at "type" ?~ J.String typ+ & at "label" ?~ J.String lbl+ & at "available" ?~ J.Bool False+ & at "item_count" ?~ J.Number (fromIntegral nparts)+ & at "camera_positions" ?~ J.String "default"+ & at "on_public_profile" ?~ J.Bool False+ & at "access_token" ?~ J.String (T.pack token)+ & at "gopro_user_id" ?~ J.String (T.pack userID))+ fromJust . preview (key "id" . _String) <$> jpostVal (authOpts token) "https://api.gopro.com/derivatives" d1++data UploadPart = UploadPart {+ _uploadLength :: Integer,+ _uploadPart :: Integer,+ _uploadURL :: String+ } deriving Show++makeLenses ''UploadPart++data Upload = Upload {+ _uploadID :: UploadID,+ _uploadParts :: [UploadPart]+ } deriving Show++makeLenses ''Upload++chunkSize :: Integer+chunkSize = 6291456++-- | Create a new upload for a derivative.+createUpload :: MonadIO m+ => DerivativeID -- ^ The derivative into which we're uploading.+ -> Int -- ^ The part number (1-based) being uploaded.+ -> Int -- ^ The size of the file being uploaded in this part.+ -> Uploader m Upload+createUpload did part fsize = do+ Env{..} <- get+ let u1 = J.Object (mempty & at "derivative_id" ?~ J.String did+ & at "camera_position" ?~ J.String "default"+ & at "item_number" ?~ J.Number (fromIntegral part)+ & at "access_token" ?~ J.String (T.pack token)+ & at "gopro_user_id" ?~ J.String (T.pack userID))+ ur <- jpost token "https://api.gopro.com/user-uploads" u1++ let Just upid = ur ^? key "id" . _String+ upopts = authOpts token & params .~ [("id", upid),+ ("page", "1"),+ ("per_page", "100"),+ ("item_number", (T.pack . show) part),+ ("camera_position", "default"),+ ("file_size", (T.pack . show) fsize),+ ("part_size", (T.pack . show) chunkSize)]+ & header "Accept" .~ ["application/vnd.gopro.jk.user-uploads+json; version=2.0.0"]+ upaths <- (jgetWith upopts (T.unpack ("https://api.gopro.com/user-uploads/" <> did)))+ let Just ups = (upaths :: J.Value) ^? key "_embedded" . key "authorizations" . _Array . to V.toList+ pure $ Upload upid (fromJust $ traverse aChunk ups)++ where+ popts tok = authOpts tok & header "Accept" .~ ["application/vnd.gopro.jk.user-uploads+json; version=2.0.0"]+ jpost :: MonadIO m => String -> String -> J.Value -> m J.Value+ jpost tok = jpostVal (popts tok)++ tInt :: T.Text -> Integer+ tInt = read . T.unpack++ aChunk v = liftA3 UploadPart (v ^? key "Content-Length" . _String . to tInt)+ (v ^? key "part" . _Integer . to toInteger)+ (v ^? key "url" . _String . to T.unpack)++-- | Upload a chunk of of the given file as specified by this UploadPart.+uploadChunk :: (MonadMask m, MonadIO m)+ => FilePath -- ^ The path being uploaded.+ -> UploadPart -- ^ The UploadPart describing the chunk of upload being transferred+ -> Uploader m ()+uploadChunk fp UploadPart{..} = recoverAll policy $ \r -> do+ when (rsIterNumber r > 0) $ gets logAction >>= \f -> lift (f (retryMsg (rsIterNumber r)))+ liftIO $ withFile fp ReadMode $ \fh -> do+ hSeek fh AbsoluteSeek ((_uploadPart - 1) * chunkSize)+ void $ putWith defOpts _uploadURL =<< BL.hGet fh (fromIntegral _uploadLength)++ where policy = exponentialBackoff 2000000 <> limitRetries 5+ retryMsg a = mconcat ["Retrying upload of ", show fp,+ " part ", show _uploadPart, " attempt ", show a]++-- | Mark the given upload for the given derivative as complete.+completeUpload :: MonadIO m+ => UploadID -- ^ The upload ID.+ -> DerivativeID -- ^ The derivative ID.+ -> Int -- ^ The part number within the derivative.+ -> Integer -- ^ The size of the file that was uploaded.+ -> Uploader m ()+completeUpload upid did part fsize = do+ Env{..} <- get+ let u2 = J.Object (mempty & at "id" ?~ J.String upid+ & at "item_number" ?~ J.Number (fromIntegral part)+ & at "camera_position" ?~ J.String "default"+ & at "complete" ?~ J.Bool True+ & at "derivative_id" ?~ J.String did+ & at "file_size" ?~ J.String ((T.pack . show) fsize)+ & at "part_size" ?~ J.String ((T.pack . show) chunkSize))+ void . liftIO $ putWith (popts token) (T.unpack ("https://api.gopro.com/user-uploads/" <> did)) u2++ where+ popts tok = authOpts tok & header "Accept" .~ ["application/vnd.gopro.jk.user-uploads+json; version=2.0.0"]++-- | Mark the given derivative as availble to use. This also updates+-- the medium record marking it as having completed its upload.+markAvailable :: MonadIO m => DerivativeID -> Uploader m ()+markAvailable did = do+ Env{..} <- get+ let d2 = J.Object (mempty & at "available" ?~ J.Bool True+ & at "access_token" ?~ J.String (T.pack token)+ & at "gopro_user_id" ?~ J.String (T.pack userID))++ _ <- liftIO $ putWith (popts token) (T.unpack ("https://api.gopro.com/derivatives/" <> did)) d2++ now <- liftIO $ getCurrentTime+ let done = J.Object (mempty & at "upload_completed_at" ?~ J.toJSON now+ & at "client_updated_at" ?~ J.toJSON now+ & at "revision_number" ?~ J.Number 0+ & at "access_token" ?~ J.String (T.pack token)+ & at "gopro_user_id" ?~ J.String (T.pack userID))++ void . liftIO $ putWith (popts token) (T.unpack ("https://api.gopro.com/media/" <> mediumID)) done++ where+ popts tok = authOpts tok & header "Accept" .~ ["application/vnd.gopro.jk.user-uploads+json; version=2.0.0"]++-- | Convenience action to upload a single medium.+uploadMedium :: (MonadMask m, MonadFail m, MonadIO m)+ => Token -- ^ Bearer token.+ -> UID -- ^ User ID.+ -> [FilePath] -- ^ Parts of a single medium to upload (e.g., a video file).+ -> m MediumID+uploadMedium _ _ [] = fail "no files provided"+uploadMedium tok uid fps = runUpload tok uid fps $ do+ mid <- createMedium+ did <- createSource (length fps)+ mapM_ (\(fp,n) -> do+ fsize <- toInteger . fileSize <$> (liftIO . getFileStatus) fp+ Upload{..} <- createUpload did n (fromInteger fsize)+ mapM_ (uploadChunk fp) _uploadParts+ completeUpload _uploadID did n fsize+ ) $ zip fps [1..]+ markAvailable did++ pure mid
+ test/Spec.hs view
@@ -0,0 +1,11 @@+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck as QC++tests :: [TestTree]+tests = [+ testProperty "a test property" (\x -> (x::Int) == id x)+ ]++main :: IO ()+main = defaultMain $ testGroup "All Tests" tests