feat: pull album info script

Signed-off-by: Tsung-Ju Lii <usefulalgorithm@gmail.com>

Author: usefulalgorithm

.github/scripts/pull_album_info/.gitignore

@@ -0,0 +1 @@
+dist-newstyle

.github/scripts/pull_album_info/app/Main.hs

@@ -0,0 +1,102 @@
+{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+-- Standard library imports
+import           System.Environment    (getArgs, lookupEnv)
+
+-- Third-party library imports
+import           Control.Lens          ((^?))
+import           Data.Aeson            (FromJSON (parseJSON), ToJSON,
+                                        Value (Object), decodeStrict, encode,
+                                        (.:))
+import           Data.Aeson.Lens       (AsNumber (_Integer), key, nth)
+import           Data.ByteString       (ByteString)
+import qualified Data.ByteString.Char8 as BS
+import           GHC.Generics          (Generic)
+import           Network.HTTP.Simple   (Query, getResponseBody, httpBS,
+                                        parseRequest_, setRequestHeader,
+                                        setRequestQueryString)
+
+-- Data type definitions
+data MainRelease = MainRelease {
+  released :: String,
+  imageUrl :: String,
+  labels   :: [String],
+  uri      :: String
+} deriving (Show, Eq, Generic)
+
+instance ToJSON MainRelease
+
+instance FromJSON MainRelease where
+  parseJSON (Object v) = do
+    uri <- v .: "uri"
+    released <- v .: "released"
+    images <- v .: "images"
+    imageUrl <- case images of
+        (img:_) -> img .: "resource_url"
+        []      -> fail "No images found"
+    labels <- v .: "labels" >>= traverse (.: "name")
+    return MainRelease {
+      uri = uri,
+      released = released,
+      imageUrl = imageUrl,
+      labels = labels
+    }
+
+-- Helper functions
+runDiscogsQuery :: Query -> String -> IO ByteString
+runDiscogsQuery query url = do
+  maybeKey <- lookupEnv "DISCOG_KEY"
+  maybeSecret <- lookupEnv "DISCOG_SECRET"
+  (key, secret) <- case (maybeKey, maybeSecret) of
+    (Just k, Just s) -> return (k, s)
+    _ -> error "Environment variables DISCOG_KEY and/or DISCOG_SECRET are not set"
+  let request =
+        setRequestQueryString query $
+        setRequestHeader "Authorization" [BS.pack $ "Discogs key=" ++ key ++ ", secret=" ++ secret] $
+        setRequestHeader "User-Agent" ["pull-album-info/1.0 (usefulalgorithm@gmail.com)"] $
+        parseRequest_ url
+  getResponseBody <$> httpBS request
+
+getMasterReleaseId :: String -> String -> IO String
+getMasterReleaseId artistName albumName = do
+  let url = "https://api.discogs.com/database/search"
+      query =
+        [ ("artist", Just $ BS.pack artistName),
+          ("release_title", Just $ BS.pack albumName),
+          ("type", Just "master")
+        ]
+  body <- BS.unpack <$> runDiscogsQuery query url
+  case body ^? key "results" . nth 0 . key "master_id" . _Integer  of
+    Just masterId -> return $ show masterId
+    Nothing       -> fail "Failed to extract master_id from the response"
+
+getMainReleaseId :: String -> IO String
+getMainReleaseId masterId = do
+  let url = "https://api.discogs.com/masters/" ++ masterId
+  body <- BS.unpack <$> runDiscogsQuery [] url
+  case body ^? key "main_release" . _Integer of
+    Just mainId -> return $ show mainId
+    Nothing     -> fail "Failed to extract main_release from the response"
+
+getMainRelease :: String -> IO MainRelease
+getMainRelease releaseId = do
+  let url = "https://api.discogs.com/releases/" ++ releaseId
+  body <- runDiscogsQuery [] url
+  case (decodeStrict body :: Maybe MainRelease) of
+    Just release -> return release
+    Nothing      -> fail "Cannot decode main release"
+
+-- Main function
+main :: IO ()
+main = do
+  args <- getArgs
+  case args of
+    [artistName, albumName] -> do
+      release <- getMasterReleaseId artistName albumName
+             >>= getMainReleaseId
+             >>= getMainRelease
+      putStrLn $ BS.unpack $ BS.toStrict $ encode release
+    _ -> putStrLn "Usage: pull_album_info <artist_name> <album_name>"

.github/scripts/pull_album_info/hie.yaml

@@ -0,0 +1,2 @@
+cradle:
+  cabal:

.github/scripts/pull_album_info/pull-album-info.cabal

@@ -0,0 +1,78 @@
+cabal-version:      >= 2.0
+-- The cabal-version field refers to the version of the .cabal specification,
+-- and can be different from the cabal-install (the tool) version and the
+-- Cabal (the library) version you are using. As such, the Cabal (the library)
+-- version used must be equal or greater than the version stated in this field.
+-- Starting from the specification version 2.2, the cabal-version field must be
+-- the first thing in the cabal file.
+
+-- Initial package description 'pull-album-info' generated by
+-- 'cabal init'. For further documentation, see:
+--   http://haskell.org/cabal/users-guide/
+--
+-- The name of the package.
+name:               pull-album-info
+
+-- The package version.
+-- See the Haskell package versioning policy (PVP) for standards
+-- guiding when and how versions should be incremented.
+-- https://pvp.haskell.org
+-- PVP summary:     +-+------- breaking API changes
+--                  | | +----- non-breaking API additions
+--                  | | | +--- code changes with no API change
+version:            0.1.0.0
+
+-- A short (one-line) description of the package.
+-- synopsis:
+
+-- A longer description of the package.
+-- description:
+
+-- The license under which the package is released.
+license:            NONE
+
+-- The package author(s).
+author:             Tsung-Ju Lii
+
+-- An email address to which users can send suggestions, bug reports, and patches.
+maintainer:         usefulalgorithm@gmail.com
+
+-- A copyright notice.
+-- copyright:
+build-type:         Simple
+
+-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README.
+extra-doc-files:    CHANGELOG.md
+
+-- Extra source files to be distributed with the package, such as examples, or a tutorial module.
+-- extra-source-files:
+
+common warnings
+    ghc-options: -Wall
+
+executable pull-album-info
+    -- Import common warning flags.
+    import:           warnings
+
+    -- .hs or .lhs file containing the Main module.
+    main-is:          Main.hs
+
+    -- Modules included in this executable, other than Main.
+    -- other-modules:
+
+    -- LANGUAGE extensions used by modules in this package.
+    -- other-extensions:
+
+    -- Other library packages from which modules are imported.
+    build-depends:    base ^>=4.17.2.1,
+                      http-conduit,
+                      aeson,
+                      bytestring,
+                      lens-aeson,
+                      lens
+
+    -- Directories containing source files.
+    hs-source-dirs:   app
+
+    -- Base language which the package is written in.
+    default-language: Haskell2010