Rewrite 7digital in haskell

2026-01-20 19:13:31 +01:00
parent 3c313315c9
commit a7fca1c9fa
6 changed files with 109 additions and 121 deletions
--- a/7digital/Main.hs
+++ b/7digital/Main.hs
@@ -1,9 +1,102 @@
-import Control.Monad (void)
-import System.Process (rawSystem)
+module Main
+    ( main
+    ) where
+
+import Codec.Archive.Zip
+    ( saveEntry
+    , unEntrySelector
+    , forEntries
+    , withArchive
+    , getEntryName
+    )
+import Data.Text (StrictText)
+import qualified Data.Text as StrictText
+import qualified Data.Text.IO as StrictText
+import System.Directory (createDirectoryIfMissing, listDirectory, renameFile)
+import System.Process (readProcessWithExitCode)
 import System.Environment (getArgs)
+import System.IO (hPutStrLn, stderr)
+import System.FilePath ((<.>), (</>), takeFileName, takeExtension)
+import System.Exit (ExitCode(..), exitWith)
+import Control.Monad (foldM, when)
+import Control.Monad.IO.Class (MonadIO(..))
+import Data.List (find)
+import Data.Bifunctor (Bifunctor(..))
+import Data.Map (Map)
+import qualified Data.Map as Map

 main :: IO ()
-main = do
-    arguments <- getArgs
-    void $ rawSystem "bundle"
-        $ "exec" : "./bin/7digital.rb" : arguments
+main = getArgs >>= withArguments 
+  where
+    withArguments [sourceArchive, musicDirectory]
+        = createDirectoryIfMissing True musicDirectory
+        >> extract sourceArchive musicDirectory
+        >> probeDirectory musicDirectory
+        >>= withMetadata musicDirectory
+    withArguments _ = hPutStrLn stderr "Usage: 7digital MUSIC_ARCHIVE.zip DIRECTORY"
+        >> exitWith (ExitFailure 1)
+    withMetadata musicDirectory (metadata, anyErrors)
+        = Map.traverseWithKey (renameSong musicDirectory) metadata
+        >> when anyErrors (exitWith (ExitFailure 2))
+
+data Song = Song
+    { album :: StrictText
+    , title :: StrictText
+    , track :: StrictText
+    } deriving (Eq, Show)
+
+renameSong :: FilePath -> FilePath -> Song -> IO ()
+renameSong musicDirectory songPath Song{..} =
+    let newFileName = StrictText.unpack (paddedTrack <> " - " <> title)
+            <.> takeExtension songPath
+        newDirectory = musicDirectory </> StrictText.unpack album
+     in createDirectoryIfMissing False newDirectory
+        >> renameFile songPath (newDirectory </> newFileName)
+        >> putStrLn ("\"" <> newFileName <> "\"" <> " renamed.")
+  where
+    paddedTrack
+        | StrictText.length track <= 1 = "0" <> track
+        | otherwise = track
+
+probeDirectory :: FilePath -> IO (Map FilePath Song, Bool)
+probeDirectory musicDirectory =
+    listDirectory musicDirectory >>= foldM probeEach (Map.empty, False)
+  where
+    probeEach (metadata, _) "MissingFiles.txt"
+        = StrictText.readFile (musicDirectory </> "MissingFiles.txt")
+        >>= StrictText.hPutStr stderr
+        >> pure (metadata, True)
+    probeEach metadata songFile =
+        let metadataKey = musicDirectory </> songFile
+         in readProcessWithExitCode "ffprobe" [metadataKey] ""
+            >>= handleProbeResult metadata metadataKey . parseProbe
+    handleProbeResult (metadata, anyErrors) metadataKey (Right songProbe) =
+        pure (Map.insert metadataKey songProbe metadata, anyErrors)
+    handleProbeResult (metadata, _) metadataKey (Left missingField) =
+        let message = "Metadata \"" <> missingField
+                <> "\" is not available for " <> StrictText.pack metadataKey
+                <> "."
+         in StrictText.hPutStrLn stderr message >> pure (metadata, True)
+    parseProbe (_, _, probeOutput) = createSong
+        $ filter fieldFilter
+        $ bimap normalizeName stripValue . StrictText.breakOn ":"
+        <$> StrictText.lines (StrictText.pack probeOutput)
+    fieldFilter (name, _) = name `elem` ["title", "album", "track"]
+    createSong songFields = Song
+        <$> findByField "album" songFields
+        <*> findByField "title" songFields
+        <*> findByField "track" songFields
+    findByField needle songFields
+        | Just found <- find ((== needle) . fst) songFields = Right $ snd found
+        | otherwise = Left needle
+    normalizeName = StrictText.toLower . StrictText.strip
+    stripValue = StrictText.strip . StrictText.drop 1
+
+extract :: MonadIO m => FilePath -> FilePath -> m ()
+extract sourceArchive musicDirectory = do
+    withArchive sourceArchive (forEntries forSong)
+  where
+    forSong selector =
+        let entryName = takeFileName (unEntrySelector selector)
+         in liftIO (StrictText.putStrLn $ "Inflating " <> getEntryName selector)
+            >> saveEntry selector (musicDirectory </> entryName)