diff --git a/lrclib-client.cabal b/lrclib-client.cabal --- a/lrclib-client.cabal +++ b/lrclib-client.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: lrclib-client -version: 0.2.2 +version: 0.2.3 synopsis: A Haskell client for the LrcLib API (lyrics database) description: This library provides types and functions to interact with the @@ -29,22 +29,22 @@ import: warnings exposed-modules: LrcLib.Client, LrcLib.Types build-depends: aeson >= 2.2.3 && < 2.3, - base >= 4.18 && < 4.21, + base >= 4.19 && < 4.21, base16-bytestring >= 1.0.2 && < 1.1, bytestring >= 0.12.2 && < 0.13, cryptohash-sha256 >= 0.11.102 && < 0.12, - lens >= 5.3.5 && < 5.4, + http-client >= 0.7.19 && < 0.8, + http-client-tls >= 0.3.6 && < 0.4, + http-types >= 0.12.4 && < 0.13, mtl >= 2.3.1 && < 2.4, text >= 2.1.3 && < 2.2, - wreq >= 0.5.4 && < 0.6, - hs-source-dirs: src - default-language: GHC2021 + default-language: GHC2024 test-suite test - import: warnings + import: warnings type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs build-depends: aeson, base, bytestring, tasty, tasty-hunit, lrclib-client - default-language: GHC2021 + default-language: GHC2024 diff --git a/src/LrcLib/Client.hs b/src/LrcLib/Client.hs --- a/src/LrcLib/Client.hs +++ b/src/LrcLib/Client.hs @@ -1,24 +1,23 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -- | Module for calling LRCLIB API () module LrcLib.Client ( module LrcLib.Types, + runAPI, + runDefaultAPI, getLyrics, getCachedLyrics, getLyricsById, - requestChallenge, searchLyrics, publish', - solveChallenge, publish, - runAPI, - runDefaultAPI, + requestChallenge, + solveChallenge, ) where -import Control.Lens ((&), (&~), (.=), (.~), (^.)) import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (ask, runReaderT) import Crypto.Hash.SHA256 (hash) @@ -27,13 +26,21 @@ import Data.ByteString.Char8 qualified as BC import Data.ByteString.Lazy (ByteString) import Data.Either (fromRight) -import Data.Foldable (toList) import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding (encodeUtf8) import GHC.Stack import LrcLib.Types -import Network.Wreq +import Network.HTTP.Client + ( Request (method, path, queryString, requestBody, requestHeaders), + RequestBody (RequestBodyLBS), + Response (responseBody, responseStatus), + httpLbs, + httpNoBody, + parseRequest_, + ) +import Network.HTTP.Client.TLS (getGlobalManager) +import Network.HTTP.Types (Status (statusCode), renderSimpleQuery) import Prelude hiding (id) decode :: (A.FromJSON a, HasCallStack) => ByteString -> a @@ -42,64 +49,71 @@ Right y -> y -- | Run API action with given API url -runAPI :: Url -> API a -> IO a +runAPI :: Request -> API a -> IO a runAPI url f = runReaderT f url -- | Run API action ('runAPI') with default API url -- -- >>> runDefaultAPI $ getLyricsById 1337 --- OK Track, id: 1337, name: Speak Français, artist: Ellis feat. NOËP, album: Speak Français +-- Right Track, id: 1337, name: Speak Français, artist: Ellis feat. NOËP, album: Speak Français runDefaultAPI :: API a -> IO a -runDefaultAPI = runAPI "http://lrclib.net/api" +runDefaultAPI = runAPI $ parseRequest_ "https://lrclib.net/api" -getUrl :: String -> Text -> Text -> Text -> Integer -> API GetResponse -getUrl url track artist album duration = do - apiUrl <- ask - resp <- liftIO $ getWith opts $ apiUrl <> url - case resp ^. responseStatus . statusCode of - 404 -> pure NotFound - 200 -> pure $ OK $ decode (resp ^. responseBody) +get' :: String -> Text -> Text -> Text -> Integer -> API (Either GetError TrackData) +get' subpath track artist album duration = do + api <- ask + let req = + api + { path = api.path <> BC.pack subpath, + queryString = + renderSimpleQuery + False + [ ("track_name", encodeUtf8 track), + ("artist_name", encodeUtf8 artist), + ("album_name", encodeUtf8 album), + ("duration", BC.pack $ show duration) + ] + } + man <- liftIO getGlobalManager + resp <- liftIO $ httpLbs req man + case resp.responseStatus.statusCode of + 404 -> pure $ Left NotFound + 200 -> pure $ Right $ decode resp.responseBody s -> error $ "Unexpected status code on get endpoint: " <> show s - where - opts = - defaults &~ do - checkResponse .= (Just $ \_ _ -> pure ()) - param "track_name" .= [track] - param "artist_name" .= [artist] - param "album_name" .= [album] - param "duration" .= [T.pack $ show duration] -getLyrics, getCachedLyrics :: Text -> Text -> Text -> Integer -> API GetResponse +getLyrics, + getCachedLyrics :: + Text -> Text -> Text -> Integer -> API (Either GetError TrackData) -- | Get lyrics by track name, artist, album and duration -- Calls @\/api\/get@ -- -- >>> runDefaultAPI $ getLyrics "ThisTrackDoesntExist" "UnknownArtist" "UnknownAlbum" 1337 --- NotFound +-- Left NotFound -- -- >>> runDefaultAPI $ getLyrics "Speak Français" "Ellis feat. NOËP" "Speak Français" 201 --- OK Track, id: 1337, name: Speak Français, artist: Ellis feat. NOËP, album: Speak Français -getLyrics = getUrl "/get" +-- Right Track, id: 1337, name: Speak Français, artist: Ellis feat. NOËP, album: Speak Français +getLyrics = get' "/get" -- | The same as 'getLyrics', but for cached lyrics. -- Calls @\/api\/get-cached@ -getCachedLyrics = getUrl "/get-cached" +getCachedLyrics = get' "/get-cached" -- | Get lyrics by id -- Calls @\/api\/get\/\@ -- -- >>> runDefaultAPI $ getLyricsById 1337 --- OK Track, id: 1337, name: Speak Français, artist: Ellis feat. NOËP, album: Speak Français -getLyricsById :: Integer -> API GetResponse -getLyricsById id' = do - url <- ask - resp <- liftIO $ getWith opts $ url <> "/get/" <> show id' - case resp ^. responseStatus . statusCode of - 404 -> pure NotFound - 200 -> pure $ OK $ decode (resp ^. responseBody) +-- Right Track, id: 1337, name: Speak Français, artist: Ellis feat. NOËP, album: Speak Français +getLyricsById :: (HasCallStack) => Integer -> API (Either GetError TrackData) +getLyricsById id = do + api <- ask + let req = api {path = api.path <> "/get/" <> BC.pack (show id)} + man <- liftIO getGlobalManager + resp <- liftIO $ httpLbs req man + case resp.responseStatus.statusCode of + 404 -> pure $ Left NotFound + 200 -> pure $ Right $ decode resp.responseBody _ -> error "Unexpected status code on get endpoint" - where - opts = defaults &~ checkResponse .= (Just $ \_ _ -> pure ()) -- | Search lyrics by either text query or track-artist-album -- Calls @\/api\/search@ @@ -108,31 +122,45 @@ -- Track, id: 1337, name: Speak Français, artist: Ellis feat. NOËP, album: Speak Français searchLyrics :: SearchQuery -> API SearchResponse searchLyrics q = do - url <- ask - resp <- liftIO $ getWith opts $ url <> "/search" - pure $ decode (resp ^. responseBody) - where - opts = - defaults &~ case q of - TextQuery t -> param "q" .= [t] - TrackQuery {..} -> do - param "track_name" .= [queryName] - param "artist_name" .= toList queryArtist - param "album_name" .= toList queryAlbum + api <- ask + let req = + api + { path = api.path <> "/search", + queryString = renderSimpleQuery False $ + case q of + TextQuery t -> [("q", encodeUtf8 t)] + TrackQuery {..} -> + [("track_name", encodeUtf8 queryName)] + ++ [ ("artist_name", encodeUtf8 artist) + | Just artist <- pure queryArtist + ] + ++ [ ("album_name", encodeUtf8 album) + | Just album <- pure queryAlbum + ] + } + man <- liftIO getGlobalManager + resp <- liftIO $ httpLbs req man + pure $ decode resp.responseBody -- | Publish Lyrics ('publish') without requesting and solving challenge -- Calls @\/api\/publish@ -publish' :: PublishToken -> PublishRequest -> API PublishResponse +publish' :: (HasCallStack) => PublishToken -> PublishRequest -> API (Either PublishError ()) publish' token request = do - url <- ask - res <- liftIO $ postWith opts (url <> "/publish") body - case res ^. responseStatus . statusCode of - 400 -> pure IncorrectToken - 201 -> pure PublishOK + api <- ask + let req = + api + { method = "POST", + path = api.path <> "/publish", + requestHeaders = + api.requestHeaders <> [("X-Publish-Token", encodeUtf8 token)], + requestBody = RequestBodyLBS $ A.encode request + } + man <- liftIO getGlobalManager + res <- liftIO $ httpNoBody req man + case res.responseStatus.statusCode of + 400 -> pure $ Left IncorrectToken + 201 -> pure $ Right () s -> error $ "Unexpected status code on publish endpoint: " <> show s - where - body = A.toJSON request - opts = defaults & header "X-Publish-Token" .~ [encodeUtf8 token] -- | Request proof-of-work challenge for publish -- Calls @\/api\/request-challenge@ @@ -141,16 +169,11 @@ -- Challenge {prefix = "BVNC...XoVu1H", target = "000000FF0...00000"} requestChallenge :: API Challenge requestChallenge = do - url <- ask - resp <- liftIO $ post (url <> "/request-challenge") $ A.toJSON () - pure $ decode (resp ^. responseBody) - --- | Publish Lyrics (request and solve challenge) --- Calls @\/api\/publish@ -publish :: PublishRequest -> API PublishResponse -publish r = do - c <- requestChallenge - publish' (solveChallenge c) r + api <- ask + let req = api {method = "POST", path = api.path <> "/request-challenge"} + man <- liftIO getGlobalManager + resp <- liftIO $ httpLbs req man + pure $ decode resp.responseBody -- | Solve proof-of-work challenge for publish -- Solution is a one-time publish token @@ -162,3 +185,10 @@ go :: Int -> Text go n | hash (prefix' <> BC.pack (show n)) < target' = prefix <> ":" <> T.show n go n = go (n + 1) + +-- | Publish Lyrics (request and solve challenge) +-- Calls @\/api\/publish@ +publish :: (HasCallStack) => PublishRequest -> API (Either PublishError ()) +publish r = do + c <- requestChallenge + publish' (solveChallenge c) r diff --git a/src/LrcLib/Types.hs b/src/LrcLib/Types.hs --- a/src/LrcLib/Types.hs +++ b/src/LrcLib/Types.hs @@ -6,14 +6,13 @@ module LrcLib.Types ( API, - Url, SearchResponse, Challenge (..), - GetResponse (..), + GetError (..), TrackData (..), SearchQuery (..), + PublishError (..), PublishToken, - PublishResponse (..), PublishRequest (..), ) where @@ -23,12 +22,10 @@ import Data.Text (Text) import Data.Text qualified as T import GHC.Generics (Generic) - --- | Representation of API url -type Url = String +import Network.HTTP.Client (Request) --- | Monad for API actions that includes API url -type API = ReaderT Url IO +-- | Monad for API actions that includes API url (as a base request) +type API = ReaderT Request IO -- | Crypto proof-of-work challenge for publish data Challenge @@ -52,10 +49,8 @@ } deriving (A.FromJSON, Generic, Eq, Read) --- | Response when getting lyrics -data GetResponse - = NotFound - | OK TrackData +-- | Error when getting lyrics +data GetError = NotFound deriving (Generic, A.FromJSON, Show) type PublishToken = Text @@ -72,8 +67,8 @@ } deriving (Generic, A.ToJSON) --- | Response when publishing lyrics -data PublishResponse = PublishOK | IncorrectToken +-- | Error when publishing lyrics +data PublishError = IncorrectToken -- | Query for search. Either text or track+artist+album data SearchQuery