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.3 +version: 0.3.0 synopsis: A Haskell client for the LrcLib API (lyrics database) description: This library provides types and functions to interact with the @@ -28,6 +28,7 @@ library import: warnings exposed-modules: LrcLib.Client, LrcLib.Types + other-modules: LrcLib.HTTP build-depends: aeson >= 2.2.3 && < 2.3, base >= 4.19 && < 4.21, base16-bytestring >= 1.0.2 && < 1.1, diff --git a/src/LrcLib/Client.hs b/src/LrcLib/Client.hs --- a/src/LrcLib/Client.hs +++ b/src/LrcLib/Client.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -18,32 +19,28 @@ ) where -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Reader (ask, runReaderT) +import Control.Monad.Reader (runReaderT) import Crypto.Hash.SHA256 (hash) import Data.Aeson qualified as A +import Data.ByteString (ByteString) import Data.ByteString.Base16 qualified as B16 import Data.ByteString.Char8 qualified as BC -import Data.ByteString.Lazy (ByteString) import Data.Either (fromRight) import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding (encodeUtf8) import GHC.Stack +import LrcLib.HTTP as HTTP import LrcLib.Types import Network.HTTP.Client - ( Request (method, path, queryString, requestBody, requestHeaders), - RequestBody (RequestBodyLBS), + ( Request, Response (responseBody, responseStatus), - httpLbs, - httpNoBody, parseRequest_, ) -import Network.HTTP.Client.TLS (getGlobalManager) -import Network.HTTP.Types (Status (statusCode), renderSimpleQuery) +import Network.HTTP.Types (Status (statusCode)) import Prelude hiding (id) -decode :: (A.FromJSON a, HasCallStack) => ByteString -> a +decode :: (A.FromJSON a, HasCallStack) => ByteStringL -> a decode x = case A.eitherDecode x of Left err -> error $ "Error while decoding JSON: " <> err Right y -> y @@ -59,27 +56,20 @@ runDefaultAPI :: API a -> IO a runDefaultAPI = runAPI $ parseRequest_ "https://lrclib.net/api" -get' :: String -> Text -> Text -> Text -> Integer -> API (Either GetError TrackData) +get' :: ByteString -> 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 + resp <- HTTP.get subpath query 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 + query = + [ ("track_name", track), + ("artist_name", artist), + ("album_name", album), + ("duration", T.show duration) + ] getLyrics, getCachedLyrics :: @@ -106,10 +96,7 @@ -- 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 + resp <- HTTP.get ("/get/" <> BC.pack (show id)) [] case resp.responseStatus.statusCode of 404 -> pure $ Left NotFound 200 -> pure $ Right $ decode resp.responseBody @@ -122,42 +109,24 @@ -- Track, id: 1337, name: Speak Français, artist: Ellis feat. NOËP, album: Speak Français searchLyrics :: SearchQuery -> API SearchResponse searchLyrics q = do - 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 + resp <- HTTP.get "/search" query pure $ decode resp.responseBody + where + query = case q of + TextQuery t -> [("q", t)] + TrackQuery {..} -> + [("track_name", queryName)] + ++ [("artist_name", artist) | Just artist <- pure queryArtist] + ++ [("album_name", album) | Just album <- pure queryAlbum] -- | Publish Lyrics ('publish') without requesting and solving challenge -- Calls @\/api\/publish@ publish' :: (HasCallStack) => PublishToken -> PublishRequest -> API (Either PublishError ()) publish' token request = do - 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 + resp <- + HTTP.post "/publish" [("X-Publish-Token", encodeUtf8 token)] $ + A.encode request + case resp.responseStatus.statusCode of 400 -> pure $ Left IncorrectToken 201 -> pure $ Right () s -> error $ "Unexpected status code on publish endpoint: " <> show s @@ -169,10 +138,7 @@ -- Challenge {prefix = "BVNC...XoVu1H", target = "000000FF0...00000"} requestChallenge :: API Challenge requestChallenge = do - api <- ask - let req = api {method = "POST", path = api.path <> "/request-challenge"} - man <- liftIO getGlobalManager - resp <- liftIO $ httpLbs req man + resp <- HTTP.post "/request-challenge" [] "" pure $ decode resp.responseBody -- | Solve proof-of-work challenge for publish diff --git a/src/LrcLib/HTTP.hs b/src/LrcLib/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/LrcLib/HTTP.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module LrcLib.HTTP where + +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (ask) +import Data.Bifunctor (second) +import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as BSL +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import LrcLib.Types +import Network.HTTP.Client + ( Request (method, path, queryString, requestBody, requestHeaders), + RequestBody (RequestBodyLBS), + Response, + httpLbs, + ) +import Network.HTTP.Client.TLS (getGlobalManager) +import Network.HTTP.Types (RequestHeaders, renderSimpleQuery) + +type ByteStringL = BSL.ByteString + +post :: + ByteString -> RequestHeaders -> ByteStringL -> API (Response ByteStringL) +post subpath requestHeaders body = do + api <- ask + let req = + api + { method = "POST", + path = api.path <> subpath, + requestHeaders, + requestBody = RequestBodyLBS body + } + liftIO do + man <- getGlobalManager + httpLbs req man + +get :: ByteString -> [(ByteString, Text)] -> API (Response ByteStringL) +get subpath query = do + api <- ask + let req = + api + { path = api.path <> subpath, + queryString = + renderSimpleQuery False $ map (second encodeUtf8) query + } + liftIO do + man <- getGlobalManager + httpLbs req man