diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# 1.0.0 + +Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017, Ollie Charles + +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 Ollie Charles 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/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/listenbrainz-client.cabal b/listenbrainz-client.cabal new file mode 100644 --- /dev/null +++ b/listenbrainz-client.cabal @@ -0,0 +1,30 @@ +name: listenbrainz-client +version: 1.0.0 +synopsis: A client library to the ListenBrainz project +homepage: https://github.com/ocharles/listenbrainz-client +license: BSD3 +license-file: LICENSE +author: Ollie Charles +maintainer: ollie@ocharles.org.uk +category: Web +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.10 + +library + exposed-modules: Web.ListenBrainz + build-depends: aeson >= 1.0.2.1, + base >=4.9 && <4.10, + free >= 4.12.4, + freer-effects >= 0.3.0.1, + http-client >= 0.5.7.0, + kan-extensions >= 5.0.2, + mtl >= 2.2.1, + servant >= 0.9.1.1, + servant-client >= 0.9.1.1, + text >= 1.2.2.1, + time >= 1.6.0.1, + transformers >= 0.5.2.0 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall diff --git a/src/Web/ListenBrainz.hs b/src/Web/ListenBrainz.hs new file mode 100644 --- /dev/null +++ b/src/Web/ListenBrainz.hs @@ -0,0 +1,375 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Web.ListenBrainz + ( MonadListenBrainz(..) + , runListenBrainzEff + , runListenBrainzT + + -- * API Calls + -- ** Submitting Listens + , submitListens + , SubmitListens(..) + , ListenData(..) + , TrackMetadata(..) + + -- ** Retrieving Listens + , Listens(..) + , getListens + + -- ** Retrieving Import Timestamps + , getLatestImport + + -- ** Updating Import Timestamps + , updateLatestImport + + -- * Types + , UserToken(..) + + -- * Implementation Details + , ListenBrainzAPICall(..) + , ListenBrainzT(..) + , performAPICall + , ListenBrainzAPI + ) where + +import Control.Monad +import qualified Control.Monad.Except as MTL +import Control.Monad.Free +import Control.Monad.Freer +import Control.Monad.Freer.Exception +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import Data.Aeson (FromJSON(..), ToJSON(..), (.=), (.:)) +import qualified Data.Aeson as JSON +import Data.Functor.Coyoneda +import Data.Monoid +import Data.Proxy (Proxy(..)) +import Data.String (IsString) +import Data.Text (Text) +import Data.Time (UTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) +import GHC.Generics +import Network.HTTP.Client (Manager) +import Servant.API +import Servant.Client + +-- | A submission of listens to ListenBrainz. +-- +-- The ListenBrainz documentation states: +-- +-- Listens should be submitted for tracks when the user has listened to half +-- the track or 4 minutes of the track, whichever is lower. If the user hasn’t +-- listened to 4 minutes or half the track, it doesn’t fully count as a listen +-- and should not be submitted. +data SubmitListens + = SingleListen ListenData + -- ^ Submit a single track. + | NowPlaying TrackMetadata + -- ^ Submit now playing information. + | Import [ListenData] + -- ^ Submit a batch of listens as an import. + + +instance ToJSON SubmitListens where + toJSON l = + case l of + SingleListen l' -> + JSON.object + [ "listen_type" .= JSON.String "single" + , "payload" .= [ l' ] + ] + + NowPlaying track -> + JSON.object + [ "listen_type" .= JSON.String "playing_now" + , "payload" .= [ JSON.object [ "track_metadata" .= track ] ] + ] + + Import listens -> + JSON.object + [ "listen_type" .= JSON.String "import" + , "payload" .= listens + ] + + +data ListenData = ListenData + { listenListenedAt :: UTCTime + , listenTrackMetadata :: TrackMetadata + } deriving (Eq, Ord, Read, Show, Generic) + + +instance ToJSON ListenData where + toJSON ListenData {..} = + JSON.object + [ "listened_at" .= utcTimeToPOSIXSeconds listenListenedAt + , "track_metadata" .= listenTrackMetadata + ] + + +instance FromJSON ListenData where + parseJSON = JSON.withObject "ListenData" $ \o -> + do + listenListenedAt <- + fmap posixSecondsToUTCTime (o .: "listened_at") + + listenTrackMetadata <- + o .: "track_metadata" + + pure ListenData{..} + + +data TrackMetadata = TrackMetadata + { trackArtist :: Text + , trackName :: Text + } deriving (Eq, Ord, Read, Show, Generic) + + +instance ToJSON TrackMetadata where + toJSON TrackMetadata {..} = + JSON.object + [ "artist_name" .= trackArtist + , "track_name" .= trackName + ] + + +instance FromJSON TrackMetadata where + parseJSON = JSON.withObject "TrackMetadata" $ \o -> + do + trackArtist <- + o .: "artist_name" + + trackName <- + o .: "track_name" + + pure TrackMetadata{..} + + +newtype Authorization = Authorization Text + + +instance ToHttpApiData Authorization where + toUrlPiece (Authorization a) = a + + +newtype UserName = UserName Text + + +instance ToHttpApiData UserName where + toUrlPiece (UserName u) = u + + +newtype TimeStamp = TimeStamp UTCTime + + +instance ToJSON TimeStamp where + toJSON (TimeStamp t) = + JSON.object [ "ts" .= utcTimeToPOSIXSeconds t ] + + +data LatestImport = LatestImport + { latestImportUserId :: Text + , latestImportTimestamp :: UTCTime + } deriving (Eq, Ord, Read, Show, Generic) + + +instance FromJSON LatestImport where + parseJSON = JSON.withObject "LatestImport" $ \o -> + do + latestImportUserId <- + o .: "musicbrainz_id" + + latestImportTimestamp <- + fmap posixSecondsToUTCTime (o .: "latest_import") + + pure LatestImport {..} + + +type ListenBrainzAPI = + Header "Authorization" Authorization :> "1" :> "submit-listens" :> ReqBody '[JSON] SubmitListens :> Post '[ JSON ] JSON.Value + :<|> "1" :> "latest-import" :> QueryParam "user_name" UserName :> Get '[ JSON ] LatestImport + :<|> Header "Authorization" Authorization :> "1" :> "latest-import" :> ReqBody '[ JSON ] TimeStamp :> Post '[ JSON ] JSON.Value + :<|> "1" :> "user" :> Capture "user-name" Text :> "listens" :> QueryParam "max_ts" Int :> QueryParam "min_ts" Int :> QueryParam "count" Int :> Get '[ JSON ] Listens + + +-- | Possible API calls, tagged with their successful return value. +data ListenBrainzAPICall a where + SubmitListens :: UserToken -> SubmitListens -> ListenBrainzAPICall JSON.Value + GetLatestImport :: Text -> ListenBrainzAPICall LatestImport + UpdateLatestImport :: UserToken -> UTCTime -> ListenBrainzAPICall JSON.Value + GetListens :: Text -> Maybe Int -> Maybe Int -> Maybe Int -> ListenBrainzAPICall [ListenData] + + +performAPICall :: Manager -> ListenBrainzAPICall a -> IO (Either ServantError a) +performAPICall m call = + runClientM + (case call of + SubmitListens userToken listen -> + apiPostSubmitListen + (Just (tokenToAuthHeader userToken)) + listen + + GetLatestImport userName -> + apiGetLatestImport + (Just (UserName userName)) + + UpdateLatestImport userToken ts -> + apiPostLatestImport + (Just (tokenToAuthHeader userToken)) + (TimeStamp ts) + + GetListens userName maxTs minTs count -> + fmap (\(Listens l) -> l) + (apiGetListens + userName + maxTs + minTs + count)) + + (ClientEnv m baseUrl) + + where + apiPostSubmitListen :<|> apiGetLatestImport :<|> apiPostLatestImport :<|> apiGetListens = + client (Proxy @ListenBrainzAPI) + + tokenToAuthHeader (UserToken userToken) = + Authorization $ "Token " <> userToken + + +-- | The class of monads that can embed calls to the ListenBrainz API. +class Monad m => MonadListenBrainz m where + liftListenBrainz :: Free (Coyoneda ListenBrainzAPICall) a -> m a + + +{-# INLINEABLE submitListens #-} +submitListens + :: MonadListenBrainz m + => UserToken -- ^ The private token of the user to submit a listen for. + -> SubmitListens + -> m JSON.Value +submitListens userKey listen = + liftListenBrainz (liftF (liftCoyoneda (SubmitListens userKey listen))) + + +getLatestImport + :: MonadListenBrainz m + => Text -- ^ The user name (not user token) of the user to find the latest import timestamp + -> m LatestImport +getLatestImport userName = + liftListenBrainz (liftF (liftCoyoneda (GetLatestImport userName))) + + +updateLatestImport + :: MonadListenBrainz m + => UserToken + -> UTCTime + -> m JSON.Value +updateLatestImport userName utcTime = + liftListenBrainz (liftF (liftCoyoneda (UpdateLatestImport userName utcTime))) + + +getListens + :: MonadListenBrainz m + => Text + -> Maybe Int + -> Maybe Int + -> Maybe Int + -> m [ListenData] +getListens userName maxTs minTs count = + liftListenBrainz (liftF (liftCoyoneda (GetListens userName maxTs minTs count))) + + +newtype Listens = Listens [ListenData] + + +instance FromJSON Listens where + parseJSON = JSON.withObject "Listens" $ \o -> + do + payload <- + o .: "payload" + + fmap Listens (payload .: "listens") + + +-- An implementation for freer-effects. Re-interpret a sequence of API calls +-- 'send's for those calls. +instance Member ListenBrainzAPICall effs => MonadListenBrainz (Eff effs) where + liftListenBrainz f = iterM (join . lowerCoyoneda . hoistCoyoneda send) f + + +-- | Eliminate 'ListenBrainzAPICall' effects by performing HTTP calls. +-- +-- This implementation uses extensible effects as provided by @freer-effects@. +runListenBrainzEff + :: (Member IO effs, Member (Exc ServantError) effs) + => Manager -> Eff (ListenBrainzAPICall ': effs) a -> Eff effs a +runListenBrainzEff m = + handleRelay + return + (\op next -> + do + res <- + send (performAPICall m op) + + case res of + Left e -> + throwError e + + Right ok -> + next ok) + + +-- | A monad transformer to interpret ListenBrainz API calls as HTTP calls. +newtype ListenBrainzT m a = ListenBrainzT (ReaderT Manager m a) + deriving (Monad, Applicative, Functor, MonadIO, MTL.MonadTrans) + + +-- | Run ListenBrainz calls using a traditional monad transformer stack. +runListenBrainzT :: ListenBrainzT m a -> Manager -> m a +runListenBrainzT (ListenBrainzT (ReaderT m)) = m + + +instance (MonadIO m, MTL.MonadError ServantError m) => MonadListenBrainz (ListenBrainzT m) where + liftListenBrainz = + iterM (join . lowerCoyoneda . hoistCoyoneda go) + + where + go :: (MonadIO m, MTL.MonadError ServantError m) => ListenBrainzAPICall a -> ListenBrainzT m a + go apiCall = + do + m <- + ListenBrainzT ask + + res <- + liftIO + (performAPICall m apiCall) + + case res of + Left e -> + MTL.lift (MTL.throwError e) + + Right ok -> + return ok + + +baseUrl :: BaseUrl +baseUrl = + BaseUrl + { baseUrlScheme = Https + , baseUrlHost = "listenbrainz.org" + , baseUrlPort = 443 + , baseUrlPath = "" + } + + +newtype UserToken = UserToken Text + deriving (IsString)