diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for gopro-plus + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/gopro-plus.cabal b/gopro-plus.cabal new file mode 100644 --- /dev/null +++ b/gopro-plus.cabal @@ -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 +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 diff --git a/src/GoPro/Plus/Auth.hs b/src/GoPro/Plus/Auth.hs new file mode 100644 --- /dev/null +++ b/src/GoPro/Plus/Auth.hs @@ -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] diff --git a/src/GoPro/Plus/Internal/HTTP.hs b/src/GoPro/Plus/Internal/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/GoPro/Plus/Internal/HTTP.hs @@ -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) diff --git a/src/GoPro/Plus/Media.hs b/src/GoPro/Plus/Media.hs new file mode 100644 --- /dev/null +++ b/src/GoPro/Plus/Media.hs @@ -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) + diff --git a/src/GoPro/Plus/Upload.hs b/src/GoPro/Plus/Upload.hs new file mode 100644 --- /dev/null +++ b/src/GoPro/Plus/Upload.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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