{-# 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,
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,
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)
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'
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 :: 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 ()