Client.hs

{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- | Module for calling LRCLIB API (<https://lrclib.net/docs>)
module LrcLib.Client
  ( module LrcLib.Types,
    runAPI,
    runDefaultAPI,
    getLyrics,
    getCachedLyrics,
    getLyricsById,
    searchLyrics,
    publish',
    publish,
    requestChallenge,
    solveChallenge,
  )
where

import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask, runReaderT)
import Crypto.Hash.SHA256 (hash)
import Data.Aeson qualified as A
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.Types
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
decode x = case A.eitherDecode x of
  Left err -> error $ "Error while decoding JSON: " <> err
  Right y -> y

-- | Run API action with given API url
runAPI :: Request -> API a -> IO a
runAPI url f = runReaderT f url

-- | Run API action ('runAPI') with default API url
--
-- >>> runDefaultAPI $ getLyricsById 1337
-- Right Track, id: 1337, name: Speak Français, artist: Ellis feat. NOËP, album: Speak Français
runDefaultAPI :: API a -> IO a
runDefaultAPI = runAPI $ parseRequest_ "https://lrclib.net/api"

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

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
-- Left NotFound
--
-- >>> runDefaultAPI $ getLyrics "Speak Français" "Ellis feat. NOËP" "Speak Français" 201
-- 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 = get' "/get-cached"

-- | Get lyrics by id
-- Calls @\/api\/get\/\<id\>@
--
-- >>> runDefaultAPI $ getLyricsById 1337
-- 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"

-- | Search lyrics by either text query or track-artist-album
-- Calls @\/api\/search@
--
-- >>> head <$> (runDefaultAPI $ searchLyrics $ TextQuery "Speak Français")
-- 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
  pure $ decode resp.responseBody

-- | 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
    400 -> pure $ Left IncorrectToken
    201 -> pure $ Right ()
    s -> error $ "Unexpected status code on publish endpoint: " <> show s

-- | Request proof-of-work challenge for publish
-- Calls @\/api\/request-challenge@
--
-- >>> runDefaultAPI requestChallenge
-- 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
  pure $ decode resp.responseBody

-- | Solve proof-of-work challenge for publish
-- Solution is a one-time publish token
solveChallenge :: Challenge -> Text
solveChallenge Challenge {prefix, target} = go 0
  where
    prefix' = encodeUtf8 prefix
    target' = fromRight (error "Can't decode target from crypto-challenge") $ B16.decode $ encodeUtf8 target
    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