{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
module GoPro.Plus.Upload (
uploadMedium,
runUpload, resumeUpload,
createMedium, createSource, createDerivative, createUpload,
completeUpload, getUpload, uploadChunk, markAvailable,
UploadID, DerivativeID,
UploadPart(..), uploadLength, uploadPart, uploadURL,
Upload(..), uploadID, uploadParts,
Uploader,
setMediumType, setLogAction,
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.Auth (AuthInfo (..), HasGoProAuth (..))
import GoPro.Plus.Internal.AuthHTTP
import GoPro.Plus.Internal.HTTP
import GoPro.Plus.Media (Medium (..), MediumID, MediumType (..), ReadyToViewType (..), list,
putMedium)
type UploadID = T.Text
type DerivativeID = T.Text
type Uploader m = StateT (Env m) m
instance MonadUnliftIO m => MonadUnliftIO (StateT (Env m) m) where
withRunInIO inner =
get >>= \st -> StateT $ \_ ->
withRunInIO $ \run -> (,st) <$> inner (run . flip evalStateT st)
instance HasGoProAuth m => HasGoProAuth (Uploader m) where
goproAuth = lift goproAuth
data Env m = Env {
fileList :: [FilePath],
mediumType :: MediumType,
extension :: T.Text,
filename :: String,
mediumID :: MediumID,
logAction :: (MonadMask m, Monad m) => String -> m ()
}
listUploading :: (HasGoProAuth m, MonadIO m) => m [Medium]
listUploading = filter (\Medium{..} -> _medium_ready_to_view == ViewUploading) . fst <$> list 30 1
runUpload :: (HasGoProAuth m, MonadFail m, MonadIO m)
=> [FilePath]
-> Uploader m a
-> m a
runUpload fileList = resumeUpload fileList ""
resumeUpload :: (HasGoProAuth m, MonadFail m, MonadIO m) => [FilePath] -> MediumID -> Uploader m a -> m a
resumeUpload [] _ _ = fail "empty file list"
resumeUpload fileList@(fp:_) mediumID a =
goproAuth >>= \AuthInfo{..} -> 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
setMediumType :: Monad m => MediumType -> Uploader m ()
setMediumType t = modify (\m -> m{mediumType=t})
setLogAction :: (Monad m, MonadMask m) => (String -> m ()) -> Uploader m ()
setLogAction t = modify (\m -> m{logAction=t})
jpostVal :: (HasGoProAuth m, MonadIO m) => Options -> String -> J.Value -> m J.Value
jpostVal opts u v = liftIO $ jpostWith opts u v
jpostAuthVal :: (HasGoProAuth m, MonadIO m) => String -> J.Value -> m J.Value
jpostAuthVal = jpostAuth
createMedium :: (HasGoProAuth m, MonadIO m) => Uploader m MediumID
createMedium = do
Env{..} <- get
AuthInfo{..} <- goproAuth
let m1 = J.Object (mempty & at "file_extension" ?~ J.String extension
& at "filename" ?~ J.String (T.pack filename)
& at "type" ?~ J.toJSON 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 _access_token
& at "gopro_user_id" ?~ J.String _resource_owner_id)
m <- fromJust . preview (key "id" . _String) <$> jpostAuthVal "https://api.gopro.com/media" m1
modify (\s -> s{mediumID=m})
pure m
createSource :: (HasGoProAuth m, MonadIO m) => Int -> Uploader m DerivativeID
createSource nparts = createDerivative nparts "Source" "Source"
createDerivative :: (HasGoProAuth m, MonadIO m)
=> Int
-> T.Text
-> T.Text
-> Uploader m DerivativeID
createDerivative nparts typ lbl = do
Env{..} <- get
AuthInfo{..} <- goproAuth
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 _access_token
& at "gopro_user_id" ?~ J.String _resource_owner_id)
fromJust . preview (key "id" . _String) <$> jpostAuthVal "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
createUpload :: (HasGoProAuth m, MonadIO m)
=> DerivativeID
-> Int
-> Int
-> Uploader m Upload
createUpload did part fsize = do
Env{..} <- get
AuthInfo{..} <- goproAuth
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 _access_token
& at "gopro_user_id" ?~ J.String _resource_owner_id)
ur <- jpost "https://api.gopro.com/user-uploads" u1
let Just upid = ur ^? key "id" . _String
getUpload upid did part fsize
where
popts tok = authOpts tok & header "Accept" .~ ["application/vnd.gopro.jk.user-uploads+json; version=2.0.0"]
jpost :: (HasGoProAuth m, MonadIO m) => String -> J.Value -> m J.Value
jpost u p = (_access_token <$> goproAuth) >>= \tok -> jpostVal (popts tok) u p
getUpload :: (HasGoProAuth m, MonadIO m)
=> UploadID
-> DerivativeID
-> Int
-> Int
-> Uploader m Upload
getUpload upid did part fsize = do
Env{..} <- get
AuthInfo{..} <- goproAuth
let pages = ceiling ((fromIntegral fsize :: Double) / fromIntegral chunkSize) :: Int
upopts = authOpts _access_token & params .~ [("id", upid),
("page", "1"),
("per_page", (T.pack . show) pages),
("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
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)
uploadChunk :: (MonadMask m, MonadIO m)
=> FilePath
-> UploadPart
-> 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 9
retryMsg a = mconcat ["Retrying upload of ", show fp,
" part ", show _uploadPart, " attempt ", show a]
completeUpload :: (HasGoProAuth m, MonadIO m)
=> UploadID
-> DerivativeID
-> Int
-> Integer
-> Uploader m ()
completeUpload upid did part fsize = do
Env{..} <- get
AuthInfo{..} <- goproAuth
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 _access_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"]
markAvailable :: (HasGoProAuth m, MonadIO m) => DerivativeID -> Uploader m ()
markAvailable did = do
Env{..} <- get
AuthInfo{..} <- goproAuth
let d2 = J.Object (mempty & at "available" ?~ J.Bool True
& at "access_token" ?~ J.String _access_token
& at "gopro_user_id" ?~ J.String _resource_owner_id)
_ <- liftIO $ putWith (popts _access_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 _access_token
& at "gopro_user_id" ?~ J.String _resource_owner_id)
putMedium mediumID done
where
popts tok = authOpts tok & header "Accept" .~ ["application/vnd.gopro.jk.user-uploads+json; version=2.0.0"]
uploadMedium :: (HasGoProAuth m, MonadMask m, MonadFail m, MonadIO m)
=> [FilePath]
-> m MediumID
uploadMedium [] = fail "no files provided"
uploadMedium fps = runUpload 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