{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module GoPro.Plus.Media (
list, listAll, listWhile, medium,
retrieve, delete,
fetchThumbnail,
PageInfo(..), current_page, per_page, total_items, total_pages,
MediumID, MediumType(..), ReadyToViewType(..),
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,
HasMediaURL(..), HasMediaLabel(..), HasMediaType(..),
File(..), file_camera_position, file_height, file_width,
file_item_number, file_orientation, file_head, file_url, file_transforms,
Variation(..), var_height, var_width, var_label, var_quality,
var_type, var_transforms, var_head, var_url,
SpriteFrame(..), frame_count, frame_height, frame_width,
Sprite(..), sprite_fps, sprite_frame, sprite_height, sprite_width,
sprite_type, sprite_heads, sprite_urls,
SidecarFile(..), sidecar_fps, sidecar_label, sidecar_type, sidecar_head, sidecar_url,
FileStuff(..), files, variations, sprites, sidecar_files,
FileInfo(..), fileStuff, filename,
Error(..), error_reason, error_code, error_description, error_id,
Moment(..), moment_id, moment_time, moments,
updateMedium, putMedium
) where
import Control.Lens
import Control.Monad.IO.Class (MonadIO (..))
import Data.Aeson (FromJSON (..), Options (..), ToJSON (..), Value (..), defaultOptions,
fieldLabelModifier, genericParseJSON, genericToEncoding, genericToJSON,
(.:))
import qualified Data.Aeson as J
import Data.Aeson.Types (typeMismatch)
import qualified Data.ByteString.Lazy as BL
import Data.Char (toLower, toUpper)
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, responseBody)
import Network.Wreq.Types (Putable)
import System.Random (getStdRandom, randomR)
import GoPro.Plus.Auth
import GoPro.Plus.Internal.AuthHTTP
import GoPro.Plus.Internal.HTTP
data PageInfo = PageInfo
{ _current_page :: Int
, _per_page :: Int
, _total_items :: Int
, _total_pages :: Int
}
deriving (Generic, Show, Eq)
makeLenses ''PageInfo
instance FromJSON PageInfo where
parseJSON = genericParseJSON jsonOpts
type MediumID = T.Text
data MediumType = Photo
| Video
| TimeLapse
| TimeLapseVideo
| Burst
deriving (Show, Read, Eq)
instance ToJSON MediumType where
toJSON = J.String . T.pack . show
instance FromJSON MediumType where
parseJSON (J.String x) = pure . read . T.unpack $ x
parseJSON invalid = typeMismatch "Response" invalid
data ReadyToViewType = ViewReady
| ViewFailure
| ViewLoading
| ViewRegistered
| ViewTranscoding
| ViewProcessing
| ViewUploading
deriving (Show, Read, Eq)
instance ToJSON ReadyToViewType where
toJSON = J.String . T.pack . fmap toLower . drop 4 . show
instance FromJSON ReadyToViewType where
parseJSON (J.String s) = pure . read . trans . T.unpack $ s
where trans (x:xs) = "View" <> (toUpper x : xs)
trans [] = error "empty ready to view type"
parseJSON invalid = typeMismatch "Response" invalid
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 :: ReadyToViewType
, _medium_source_duration :: Maybe String
, _medium_type :: MediumType
, _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}
thumbnailURL :: Int
-> Medium
-> String
thumbnailURL n Medium{_medium_token} = "https://images-0" <> show n <> ".gopro.com/resize/450wwp/" <> _medium_token
fetchThumbnail :: (HasGoProAuth m, MonadIO m) => Medium -> m BL.ByteString
fetchThumbnail m = do
n <- liftIO $ getStdRandom (randomR (1,4))
proxyAuth (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 :: (HasGoProAuth m, MonadIO m)
=> Int
-> Int
-> m ([Medium], PageInfo)
list psize page = do
r <- jgetAuth ("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)
listAll :: (HasGoProAuth m, MonadIO m) => m [Medium]
listAll = listWhile (const True)
listWhile :: (HasGoProAuth m, MonadIO m) => ([Medium] -> Bool) -> m [Medium]
listWhile f = Map.elems <$> dig 0 mempty
where
dig n m = do
(ms, _) <- list 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'
class HasMediaURL c where
media_url :: Lens' c String
class HasMediaLabel c where
media_label :: Lens' c String
class HasMediaType c where
media_type :: Lens' c String
data File = File
{ _file_camera_position :: String
, _file_height :: Int
, _file_width :: Int
, _file_item_number :: Int
, _file_orientation :: Int
, _file_transforms :: Maybe [String]
, _file_head :: String
, _file_url :: String
}
deriving (Generic, Show)
makeLenses ''File
instance HasMediaURL File where media_url = file_url
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_transforms :: Maybe [String]
, _var_type :: String
, _var_head :: String
, _var_url :: String
}
deriving (Generic, Show)
makeLenses ''Variation
instance HasMediaURL Variation where media_url = var_url
instance HasMediaLabel Variation where media_label = var_label
instance HasMediaType Variation where media_type = var_type
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_heads :: [String]
, _sprite_urls :: [String]
}
deriving (Generic, Show)
makeLenses ''Sprite
instance FromJSON Sprite where
parseJSON = genericParseJSON defaultOptions {
fieldLabelModifier = dropPrefix "_sprite_"
}
data SidecarFile = SidecarFile
{ _sidecar_fps :: Int
, _sidecar_label :: String
, _sidecar_type :: String
, _sidecar_head :: String
, _sidecar_url :: String
} deriving (Generic, Show)
makeLenses ''SidecarFile
instance HasMediaURL SidecarFile where media_url = sidecar_url
instance HasMediaLabel SidecarFile where media_label = sidecar_label
instance HasMediaType SidecarFile where media_type = sidecar_type
instance FromJSON SidecarFile where
parseJSON = genericParseJSON defaultOptions {
fieldLabelModifier = dropPrefix "_sidecar_"
}
data FileStuff = FileStuff
{ _files :: [File]
, _variations :: [Variation]
, _sprites :: [Sprite]
, _sidecar_files :: [SidecarFile]
}
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 :: MediumID -> String
dlURL k = "https://api.gopro.com/media/" <> T.unpack k <> "/download"
retrieve :: (HasGoProAuth m, FromJSON j, MonadIO m) => MediumID -> m j
retrieve k = jgetAuth (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 :: (HasGoProAuth m, MonadIO m) => MediumID -> m [Error]
delete k = do
tok <- _access_token <$> goproAuth
let u = "https://api.gopro.com/media?ids=" <> k
Errors r <- view responseBody <$> liftIO (deleteWith (authOpts tok) (T.unpack u) >>= asJSON)
pure r
mediumURL :: MediumID -> String
mediumURL = ("https://api.gopro.com/media/" <>) . T.unpack
medium :: (HasGoProAuth m, FromJSON j, MonadIO m) => MediumID -> m j
medium = jgetAuth . mediumURL
putMedium :: (HasGoProAuth m, MonadIO m, Putable a) => MediumID -> a -> m ()
putMedium mid = fmap v . jputAuth (mediumURL mid)
where
v :: Value -> ()
v = const ()
updateMedium :: (HasGoProAuth m, MonadIO m, FromJSON j, Putable a)
=> (j -> a)
-> MediumID
-> m ()
updateMedium f m = (f <$> medium m) >>= putMedium m
data Moment = Moment
{ _moment_id :: T.Text
, _moment_time :: Maybe Int
}
deriving (Show, Generic)
makeLenses ''Moment
instance FromJSON Moment where
parseJSON = genericParseJSON defaultOptions {
fieldLabelModifier = dropPrefix "_moment_"
}
instance ToJSON Moment where
toEncoding = genericToEncoding jsonOpts{ fieldLabelModifier = dropPrefix "_moment_" }
toJSON = genericToJSON jsonOpts{ fieldLabelModifier = dropPrefix "_moment_" }
newtype Moments = Moments { unMoments :: [Moment] }
instance FromJSON Moments where
parseJSON (Object v) = do
o <- v .: "_embedded"
m <- o .: "moments"
Moments <$> traverse parseJSON (V.toList m)
parseJSON invalid = typeMismatch "Response" invalid
moments :: (HasGoProAuth m, MonadIO m) => MediumID -> m [Moment]
moments mid = unMoments <$> jgetAuth ("https://api.gopro.com/media/" <> T.unpack mid <> "/moments?fields=time")