List installed packages from a repository

lib/SlackBuilder/Info.hs

@@ -7,6 +7,7 @@ module SlackBuilder.Info
     ( PackageInfo(..)
     , generate
     , parseInfoFile
+    , readInfoFile
     ) where
 
 import Control.Applicative (Alternative(..))
@@ -26,7 +27,7 @@ import Crypto.Hash (Digest, MD5, digestFromByteString)
 import Data.Void (Void)
 import Data.Word (Word8)
 import Numeric (readHex, showHex)
-import Text.Megaparsec (Parsec, count, eof, takeWhile1P)
+import Text.Megaparsec (Parsec, count, eof, parse, takeWhile1P)
 import Text.Megaparsec.Byte (space, string, hexDigitChar)
 import Text.URI
     ( URI(..)
@@ -34,6 +35,14 @@ import Text.URI
     , render
     )
 import qualified Data.Word8 as Word8
+import SlackBuilder.Trans
+    ( SlackBuilderT(..)
+    , SlackBuilderException(..)
+    , relativeToRepository
+    )
+import System.FilePath ((</>), (<.>))
+import Control.Monad.IO.Class (MonadIO(..))
+import Conduit (MonadThrow(throwM))
 
 type GenParser = Parsec Void ByteString
 
@@ -110,6 +119,17 @@ parseInfoFile = PackageInfo . Char8.unpack
         *> packageName
         <* "\"\n"
 
+readInfoFile :: Text -> Text -> SlackBuilderT PackageInfo
+readInfoFile category packageName' = do
+    let packageName'' = Text.unpack packageName'
+
+    infoPath <- relativeToRepository
+        $ Text.unpack category </> packageName'' </> packageName'' <.> "info"
+    infoContents <- liftIO $ ByteString.readFile infoPath
+
+    either (throwM . MalformedInfoFile) pure
+        $ parse parseInfoFile infoPath infoContents
+
 generate :: PackageInfo -> Text
 generate pkg = Lazy.Text.toStrict $ Text.Builder.toLazyText builder
   where

lib/SlackBuilder/Package.hs

@@ -5,7 +5,8 @@
 -- | Contains data describing packages, methods to update them and to request
 -- information about them.
 module SlackBuilder.Package
-    ( Download(..)
+    ( DataBaseEntry(..)
+    , Download(..)
     , DownloadTemplate(..)
     , PackageDescription(..)
     , PackageUpdateData(..)
@@ -66,3 +67,15 @@ data Updater = Updater
     , is64 :: Bool
     , getVersion :: Text -> Text -> SlackBuilderT Download
     }
+
+data DataBaseEntry = DataBaseEntry
+    { name :: Text
+    , version :: Text
+    , arch :: Text
+    , build :: Text
+    } deriving Eq
+
+instance Show DataBaseEntry
+  where
+    show DataBaseEntry{..} = Text.unpack
+        $ Text.intercalate "-" [name, version, arch, build]

lib/SlackBuilder/Trans.hs

@@ -10,6 +10,7 @@ module SlackBuilder.Trans
     ) where
 
 import Control.Monad.Trans.Reader (ReaderT(..), asks)
+import Data.ByteString (ByteString)
 import Data.Text (Text)
 import qualified Data.Text as Text
 import SlackBuilder.Config
@@ -20,11 +21,14 @@ import System.FilePath ((</>))
 import Text.URI (URI)
 import qualified Text.URI as URI
 import qualified Codec.Compression.Lzma as Lzma
+import Text.Megaparsec (ParseErrorBundle(..), errorBundlePretty)
+import Conduit (Void)
 
 data SlackBuilderException
     = UpdaterNotFound Text
     | UnsupportedUrlType URI
     | LzmaDecompressionFailed Lzma.LzmaRet
+    | MalformedInfoFile (ParseErrorBundle ByteString Void)
     deriving Show
 
 instance Exception SlackBuilderException
@@ -55,6 +59,8 @@ instance Exception SlackBuilderException
         "No progress is possible"
     displayException (LzmaDecompressionFailed Lzma.LzmaRetProgError) =
         "Programming error"
+    displayException (MalformedInfoFile errorBundle) =
+        errorBundlePretty errorBundle
  
 newtype SlackBuilderT a = SlackBuilderT
     { runSlackBuilderT :: ReaderT Settings IO a

src/Main.hs

@@ -17,6 +17,7 @@ import SlackBuilder.LatestVersionCheck
 import SlackBuilder.Update
 import qualified Toml
 import Data.Text (Text)
+import qualified Data.Text as Text
 import qualified Data.Text.IO as Text
 import Control.Monad.Trans.Reader (ReaderT(..), asks)
 import SlackBuilder.Package (PackageDescription(..), renderTextWithVersion)
@@ -32,6 +33,9 @@ import System.Console.ANSI
     )
 import Data.Maybe (mapMaybe)
 import qualified Text.URI as URI
+import System.Directory (listDirectory)
+import qualified Data.HashMap.Strict as HashMap
+import SlackBuilder.Info (readInfoFile)
 
 autoUpdatable :: [PackageSettings] -> [PackageDescription]
 autoUpdatable = mapMaybe go
@@ -97,6 +101,31 @@ check = SlackBuilderT (asks (getField @"packages"))
         >>= mapM_ checkUpdateAvailability
         >> liftIO (putStrLn "")
 
+installed :: SlackBuilderT ()
+installed = do
+    listing <- listRepository
+    database <- foldr createDataBase HashMap.empty . mapMaybe createEntry
+        <$> liftIO (listDirectory "/var/lib/pkgtools/packages")
+    traverse_ findInfo $ HashMap.intersectionWith (,) database listing
+  where
+    findInfo (installed'@Package.DataBaseEntry{ name }, fromRepository) = do
+        _ <- readInfoFile fromRepository name
+        liftIO $ print installed'
+    createDataBase entry@Package.DataBaseEntry{ name } =
+        HashMap.insert name entry
+    createEntry filename = createEntryFromChunks
+        $ Text.split (== '-')
+        $ Text.reverse
+        $ Text.pack filename
+    createEntryFromChunks (build : arch : version : name) = Just
+        Package.DataBaseEntry
+            { arch = Text.reverse arch
+            , build = Text.reverse build
+            , version = Text.reverse version
+            , name =  Text.reverse (Text.intercalate "-" name)
+            }
+    createEntryFromChunks _ = Nothing
+
 main :: IO ()
 main = execParser slackBuilderParser
     >>= handle handleException . withCommandLine
@@ -116,3 +145,4 @@ main = execParser slackBuilderParser
     executeCommand = \case
         CheckCommand -> check
         Up2DateCommand packageName -> up2Date packageName
+        InstalledCommand -> installed

src/SlackBuilder/CommandLine.hs

@@ -25,6 +25,7 @@ import Options.Applicative
 data SlackBuilderCommand
     = CheckCommand
     | Up2DateCommand (Maybe Text)
+    | InstalledCommand
 
 slackBuilderParser :: ParserInfo SlackBuilderCommand
 slackBuilderParser = info slackBuilderCommand fullDesc
@@ -33,7 +34,9 @@ slackBuilderCommand :: Parser SlackBuilderCommand
 slackBuilderCommand = subparser
     $ command "check" (info checkCommand mempty)
     <> command "up2date" (info up2DateCommand mempty)
+    <> command "installed" (info installedCommand mempty)
   where
     checkCommand = pure CheckCommand
     up2DateCommand = Up2DateCommand
         <$> optional (argument str (metavar "PKGNAM"))
+    installedCommand = pure InstalledCommand

src/SlackBuilder/Update.hs

@@ -8,6 +8,7 @@ module SlackBuilder.Update
     , downloadWithTemplate
     , getAndLogLatest
     , handleException
+    , listRepository
     , repackageWithTemplate
     , reuploadWithTemplate
     , updatePackageIfRequired
@@ -17,8 +18,9 @@ import Control.Exception (Exception(..), SomeException(..))
 import Control.Monad.Catch (MonadCatch(..))
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Trans.Reader (asks)
-import qualified Data.ByteString as ByteString
 import Data.Foldable (Foldable(..), find)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
 import qualified Data.List.NonEmpty as NonEmpty
 import Data.Maybe (fromJust, fromMaybe)
 import Data.Text (Text)
@@ -48,7 +50,6 @@ import SlackBuilder.Info
 import SlackBuilder.Package (PackageDescription(..), PackageUpdateData(..))
 import qualified SlackBuilder.Package as Package
 import SlackBuilder.Trans
-import Text.Megaparsec (parse, errorBundlePretty)
 import Text.URI (URI(..))
 import qualified Text.URI as URI
 import System.Directory
@@ -74,30 +75,23 @@ getAndLogLatest description = do
     let PackageDescription{ latest = Package.Updater{ detectLatest }, name } = description
     liftIO (putStrLn $ Text.unpack name <> ": Retreiving the latest version.")
     detectedVersion <- detectLatest
-    category <- fmap Text.pack
-        <$> findCategory (Text.unpack name)
+    category <- HashMap.lookup name <$> listRepository
     pure $ PackageUpdateData description
         <$> category
         <*> detectedVersion
 
 checkUpdateAvailability :: PackageUpdateData -> SlackBuilderT (Maybe PackageInfo)
 checkUpdateAvailability PackageUpdateData{..} = do
-    let name' = Text.unpack $ getField @"name" description
-        packagePath = Text.unpack category </> name' </> (name' <.> "info")
-    repository' <- SlackBuilderT $ asks repository
-    infoContents <- liftIO $ ByteString.readFile $ repository' </> packagePath
+    parsedInfoFile <- readInfoFile category $ getField @"name" description
 
-    case parse parseInfoFile packagePath infoContents of
-        Right parsedInfoFile
-            | version == getField @"version" parsedInfoFile ->
-                liftIO $ do
+    if version == getField @"version" parsedInfoFile
+    then liftIO $ do
         setSGR [SetColor Foreground Dull Green]
         Text.IO.putStrLn
             $ getField @"name" description <> " is up to date (Version " <> version <> ")."
         setSGR [Reset]
         pure Nothing
-            | otherwise ->
-                liftIO $ do
+    else liftIO $ do
         setSGR [SetColor Foreground Dull Yellow]
         Text.IO.putStr
             $ "A new version of "
@@ -107,8 +101,6 @@ checkUpdateAvailability PackageUpdateData{..} = do
         setSGR [Reset]
         putStrLn ""
         pure $ Just parsedInfoFile
-        Left errorBundle -> liftIO (putStr $ errorBundlePretty errorBundle)
-            >> pure Nothing
 
 updatePackageIfRequired :: PackageUpdateData -> SlackBuilderT ()
 updatePackageIfRequired updateData
@@ -252,19 +244,20 @@ updatePackage PackageUpdateData{..} info = do
 
     commit packagePath version
 
-findCategory :: FilePath -> SlackBuilderT (Maybe FilePath)
-findCategory packageName = do
+listRepository :: SlackBuilderT (HashMap Text Text)
+listRepository = do
     repository' <- SlackBuilderT $ asks repository
-    go repository' [] "" <&> fmap fst . find ((packageName ==) . snd)
+    listing <- go repository' [] ""
+    pure $ HashMap.fromList $ bimap Text.pack Text.pack <$> listing
   where
     go currentDirectory found accumulatedDirectory = do
         let fullDirectory = currentDirectory </> accumulatedDirectory
         contents <- liftIO $ listDirectory fullDirectory
         case find (isSuffixOf ".info") contents of
             Just _ ->
-                let result = first dropTrailingPathSeparator
+                let (category, packageName) = first dropTrailingPathSeparator
                         $ splitFileName accumulatedDirectory
-                 in pure $ result : found
+                 in pure $ (packageName, category) : found
             Nothing ->
                 let accumulatedDirectories = (accumulatedDirectory </>)
                         <$> filter (not . isPrefixOf ".") contents