diff --git a/src/Cli/Cli.hs b/src/Cli/Cli.hs index c2ab054..8799697 100644 --- a/src/Cli/Cli.hs +++ b/src/Cli/Cli.hs @@ -8,199 +8,217 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Cli.Cli - ( cliMain - ) where +module Cli.Cli ( + cliMain, +) where + +import Conduit ( + foldC, + runConduit, + (.|), + ) +import Control.Monad.Logger ( + LogLevel (..), + MonadLogger (monadLoggerLog), + MonadLoggerIO (askLoggerIO), + ToLogStr, + fromLogStr, + toLogStr, + ) +import Crypto.Hash ( + SHA256 (SHA256), + hashWith, + ) +import Data.Aeson ( + ToJSON, + eitherDecodeStrict, + ) +import Data.ByteArray.Encoding ( + Base (..), + convertToBase, + ) +import Data.ByteString.Char8 qualified as B8 +import Data.ByteString.Lazy qualified as LB +import Data.Conduit.Process (readProcess) +import Data.Default +import Data.Functor.Contravariant (contramap) +import Data.HashMap.Internal.Strict ( + HashMap, + delete, + empty, + insert, + lookup, + traverseWithKey, + ) +import Data.String.Interpolate.IsString ( + i, + ) +import Data.Text (toLower) +import Dhall ( + Encoder (embed), + FromDhall (..), + Generic, + ToDhall (..), + auto, + inject, + inputFile, + ) +import Dhall.Core (pretty) +import Handler.Admin ( + AddCategoryReq (AddCategoryReq), + IndexPkgReq (IndexPkgReq), + PackageList (..), + ) +import Lib.External.AppMgr (sourceManifest) +import Lib.Types.AppIndex ( + PkgId (..), + ) +import Lib.Types.Emver (Version (..)) +import Lib.Types.Manifest (PackageManifest (..)) +import Network.HTTP.Client.Conduit ( + StreamFileStatus (StreamFileStatus, fileSize, readSoFar), + applyBasicAuth, + httpLbs, + observedStreamFile, + ) +import Network.HTTP.Client.TLS (newTlsManager) +import Network.HTTP.Simple ( + getResponseBody, + getResponseStatus, + httpJSON, + httpLBS, + parseRequest, + setRequestBody, + setRequestBodyJSON, + setRequestHeaders, + ) +import Network.HTTP.Types (status200) +import Network.URI ( + URI, + parseURI, + ) +import Options.Applicative ( + Alternative ((<|>)), + Applicative (liftA2, pure, (<*>)), + Parser, + ParserInfo, + auto, + command, + execParser, + fullDesc, + help, + helper, + info, + liftA3, + long, + mappend, + metavar, + option, + optional, + progDesc, + short, + strArgument, + strOption, + subparser, + switch, + (<$>), + (<**>), + ) +import Rainbow ( + Chunk, + Radiant, + blue, + chunk, + fore, + green, + magenta, + putChunk, + putChunkLn, + red, + white, + yellow, + ) +import Startlude ( + Bool (..), + ConvertText (toS), + Either (..), + Eq (..), + ExitCode (..), + FilePath, + IO, + Int, + IsString (..), + Maybe (..), + Monad ((>>=)), + ReaderT (runReaderT), + Semigroup ((<>)), + Show, + String, + appendFile, + const, + decodeUtf8, + exitWith, + filter, + flip, + fmap, + for, + for_, + fromIntegral, + fromMaybe, + fst, + headMay, + not, + panic, + show, + snd, + unlessM, + void, + when, + writeFile, + zip, + ($), + ($>), + (&), + (.), + (<&>), + ) +import System.Directory ( + createDirectoryIfMissing, + doesPathExist, + getCurrentDirectory, + getFileSize, + getHomeDirectory, + listDirectory, + ) +import System.FilePath ( + takeDirectory, + takeExtension, + (), + ) +import System.ProgressBar ( + Progress (..), + defStyle, + newProgressBar, + updateProgress, + ) +import Yesod ( + logError, + logWarn, + ) -import Conduit ( (.|) - , foldC - , runConduit - ) -import Control.Monad.Logger ( LogLevel(..) - , MonadLogger(monadLoggerLog) - , MonadLoggerIO(askLoggerIO) - , ToLogStr - , fromLogStr - , toLogStr - ) -import Crypto.Hash ( SHA256(SHA256) - , hashWith - ) -import Data.Aeson ( ToJSON - , eitherDecodeStrict - ) -import Data.ByteArray.Encoding ( Base(..) - , convertToBase - ) -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Lazy as LB -import Data.Conduit.Process ( readProcess ) -import Data.Default -import Data.Functor.Contravariant ( contramap ) -import Data.HashMap.Internal.Strict ( HashMap - , delete - , empty - , insert - , lookup - , traverseWithKey - ) -import Data.String.Interpolate.IsString - ( i ) -import Data.Text ( toLower ) -import Dhall ( Encoder(embed) - , FromDhall(..) - , Generic - , ToDhall(..) - , auto - , inject - , inputFile - ) -import Dhall.Core ( pretty ) -import Handler.Admin ( AddCategoryReq(AddCategoryReq) - , IndexPkgReq(IndexPkgReq) - , PackageList(..) - ) -import Lib.External.AppMgr ( sourceManifest ) -import Lib.Types.AppIndex ( PackageManifest - ( PackageManifest - , packageManifestId - , packageManifestVersion - ) - , PkgId(..) - ) -import Lib.Types.Emver ( Version(..) ) -import Network.HTTP.Client.Conduit ( StreamFileStatus(StreamFileStatus, fileSize, readSoFar) - , applyBasicAuth - , httpLbs - , observedStreamFile - ) -import Network.HTTP.Client.TLS ( newTlsManager ) -import Network.HTTP.Simple ( getResponseBody - , getResponseStatus - , httpJSON - , httpLBS - , parseRequest - , setRequestBody - , setRequestBodyJSON - , setRequestHeaders - ) -import Network.HTTP.Types ( status200 ) -import Network.URI ( URI - , parseURI - ) -import Options.Applicative ( (<$>) - , (<**>) - , Alternative((<|>)) - , Applicative((<*>), liftA2, pure) - , Parser - , ParserInfo - , auto - , command - , execParser - , fullDesc - , help - , helper - , info - , liftA3 - , long - , mappend - , metavar - , option - , optional - , progDesc - , short - , strArgument - , strOption - , subparser - , switch - ) -import Rainbow ( Chunk - , Radiant - , blue - , chunk - , fore - , green - , magenta - , putChunk - , putChunkLn - , red - , white - , yellow - ) -import Startlude ( ($) - , ($>) - , (&) - , (.) - , (<&>) - , Bool(..) - , ConvertText(toS) - , Either(..) - , Eq(..) - , ExitCode(..) - , FilePath - , IO - , Int - , IsString(..) - , Maybe(..) - , Monad((>>=)) - , ReaderT(runReaderT) - , Semigroup((<>)) - , Show - , String - , appendFile - , const - , decodeUtf8 - , exitWith - , filter - , flip - , fmap - , for - , for_ - , fromIntegral - , fromMaybe - , fst - , headMay - , not - , panic - , show - , snd - , unlessM - , void - , when - , writeFile - , zip - ) -import System.Directory ( createDirectoryIfMissing - , doesPathExist - , getCurrentDirectory - , getFileSize - , getHomeDirectory - , listDirectory - ) -import System.FilePath ( () - , takeDirectory - , takeExtension - ) -import System.ProgressBar ( Progress(..) - , defStyle - , newProgressBar - , updateProgress - ) -import Yesod ( logError - , logWarn - ) data Upload = Upload { publishRepoName :: !String - , publishPkg :: !(Maybe FilePath) - , publishIndex :: !Bool + , publishPkg :: !(Maybe FilePath) + , publishIndex :: !Bool } - deriving Show + deriving (Show) + newtype PublishCfg = PublishCfg { publishCfgRepos :: HashMap String PublishCfgRepo } - deriving Generic + deriving (Generic) instance FromDhall PublishCfg instance ToDhall PublishCfg instance Default PublishCfg where @@ -209,23 +227,27 @@ instance Default PublishCfg where data PublishCfgRepo = PublishCfgRepo { publishCfgRepoLocation :: !URI - , publishCfgRepoUser :: !String - , publishCfgRepoPass :: !String + , publishCfgRepoUser :: !String + , publishCfgRepoPass :: !String } deriving (Show, Generic) instance FromDhall PublishCfgRepo instance ToDhall PublishCfgRepo + instance FromDhall URI where autoWith norm = fromMaybe (panic "Invalid URI for publish target") . parseURI <$> autoWith norm + instance ToDhall URI where injectWith norm = contramap (show @_ @String) (injectWith norm) + instance IsString URI where fromString = fromMaybe (panic "Invalid URI for publish target") . parseURI -data Shell = Bash | Fish | Zsh deriving Show + +data Shell = Bash | Fish | Zsh deriving (Show) data Command = CmdInit !(Maybe Shell) | CmdRegAdd !String !PublishCfgRepo @@ -238,72 +260,89 @@ data Command | CmdCatDel !String !String | CmdPkgCatAdd !String !PkgId !String | CmdPkgCatDel !String !PkgId !String - deriving Show + deriving (Show) + cfgLocation :: IO FilePath cfgLocation = getHomeDirectory <&> \d -> d ".embassy/publish.dhall" + parseInit :: Parser (Maybe Shell) parseInit = subparser $ command "init" (info go $ progDesc "Initializes embassy-publish config") <> metavar "init" where shells = [Bash, Fish, Zsh] - go = headMay . fmap fst . filter snd . zip shells <$> for shells (switch . long . toS . toLower . show) + go = headMay . fmap fst . filter snd . zip shells <$> for shells (switch . long . toS . toLower . show) + parsePublish :: Parser Upload -parsePublish = subparser $ command "upload" (info go $ progDesc "Publishes a .s9pk to a remote registry") <> metavar - "upload" +parsePublish = + subparser $ + command "upload" (info go $ progDesc "Publishes a .s9pk to a remote registry") + <> metavar + "upload" where - go = liftA3 - Upload - (strOption (short 't' <> long "target" <> metavar "NAME" <> help "Name of registry in publish.dhall")) - (optional $ strOption - (short 'p' <> long "package" <> metavar "S9PK" <> help "File path of the package to publish") - ) - (switch (short 'i' <> long "index" <> help "Index the package after uploading")) + go = + liftA3 + Upload + (strOption (short 't' <> long "target" <> metavar "NAME" <> help "Name of registry in publish.dhall")) + ( optional $ + strOption + (short 'p' <> long "package" <> metavar "S9PK" <> help "File path of the package to publish") + ) + (switch (short 'i' <> long "index" <> help "Index the package after uploading")) + parseRepoAdd :: Parser Command parseRepoAdd = subparser $ command "add" (info go $ progDesc "Add a registry to your config") <> metavar "add" where go :: Parser Command go = - let - publishCfgRepoLocation = + let publishCfgRepoLocation = strOption (short 'l' <> long "location" <> metavar "REGISTRY_URL" <> help "Registry URL") - publishCfgRepoUser = strOption - (short 'u' <> long "username" <> metavar "USERNAME" <> help "Admin username for this registry") - publishCfgRepoPass = strOption - (short 'p' <> long "password" <> metavar "PASSWORD" <> help "Admin password for this registry") + publishCfgRepoUser = + strOption + (short 'u' <> long "username" <> metavar "USERNAME" <> help "Admin username for this registry") + publishCfgRepoPass = + strOption + (short 'p' <> long "password" <> metavar "PASSWORD" <> help "Admin password for this registry") name = strOption - (short 'n' <> long "name" <> metavar "REGISTRY_NAME" <> help - "Name to reference this registry in the future" + ( short 'n' <> long "name" <> metavar "REGISTRY_NAME" + <> help + "Name to reference this registry in the future" ) r = PublishCfgRepo <$> publishCfgRepoLocation <*> publishCfgRepoUser <*> publishCfgRepoPass - in - liftA2 CmdRegAdd name r + in liftA2 CmdRegAdd name r + parseRepoDel :: Parser String parseRepoDel = subparser $ command "rm" (info go $ progDesc "Remove a registry from your config") <> metavar "rm" where - go = strOption - (short 'n' <> long "name" <> metavar "REGISTRY_NAME" <> help - "Registry name chosen when this was originally configured" - ) + go = + strOption + ( short 'n' <> long "name" <> metavar "REGISTRY_NAME" + <> help + "Registry name chosen when this was originally configured" + ) + parseRepoList :: Parser () parseRepoList = subparser $ command "ls" (info (pure ()) $ progDesc "List registries in your config") <> metavar "ls" + parseIndex :: Parser Command parseIndex = - subparser - $ command "index" (info (parseIndexHelper True) $ progDesc "Indexes an existing package version") - <> metavar "index" + subparser $ + command "index" (info (parseIndexHelper True) $ progDesc "Indexes an existing package version") + <> metavar "index" + parseDeindex :: Parser Command parseDeindex = - subparser - $ command "deindex" (info (parseIndexHelper False) $ progDesc "Deindexes an existing package version") - <> metavar "deindex" + subparser $ + command "deindex" (info (parseIndexHelper False) $ progDesc "Deindexes an existing package version") + <> metavar "deindex" + parseIndexHelper :: Bool -> Parser Command parseIndexHelper b = @@ -313,12 +352,16 @@ parseIndexHelper b = <*> strArgument (metavar "VERSION") <*> pure b + parseListUnindexed :: Parser String -parseListUnindexed = subparser $ command - "list-unindexed" - ( info (strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME")) - $ progDesc "Lists unindexed package versions on target registry" - ) +parseListUnindexed = + subparser $ + command + "list-unindexed" + ( info (strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME")) $ + progDesc "Lists unindexed package versions on target registry" + ) + parseCommand :: Parser Command parseCommand = @@ -330,31 +373,39 @@ parseCommand = <|> (CmdListUnindexed <$> parseListUnindexed) <|> parseCat <|> parsePkgCat - where reg = parseRepoAdd <|> (CmdRegDel <$> parseRepoDel) <|> (parseRepoList $> CmdRegList) + where + reg = parseRepoAdd <|> (CmdRegDel <$> parseRepoDel) <|> (parseRepoList $> CmdRegList) + parseCat :: Parser Command parseCat = subparser $ command "category" (info (add <|> del) $ progDesc "Manage categories") where - add = subparser $ command - "add" - ( info - ( CmdCatAdd - <$> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME") - <*> strArgument (metavar "CATEGORY") - <*> optional (strOption (short 'd' <> long "description" <> metavar "DESCRIPTION")) - <*> optional - (option Options.Applicative.auto (short 'p' <> long "priority" <> metavar "PRIORITY")) + add = + subparser $ + command + "add" + ( info + ( CmdCatAdd + <$> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME") + <*> strArgument (metavar "CATEGORY") + <*> optional (strOption (short 'd' <> long "description" <> metavar "DESCRIPTION")) + <*> optional + (option Options.Applicative.auto (short 'p' <> long "priority" <> metavar "PRIORITY")) + ) + $ progDesc "Adds category to registry" ) - $ progDesc "Adds category to registry" - ) - del = subparser $ command - "rm" - ( info - (CmdCatDel <$> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME") <*> strArgument - (metavar "CATEGORY") + del = + subparser $ + command + "rm" + ( info + ( CmdCatDel <$> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME") + <*> strArgument + (metavar "CATEGORY") + ) + $ progDesc "Removes category from registry" ) - $ progDesc "Removes category from registry" - ) + parsePkgCat :: Parser Command parsePkgCat = subparser $ command "categorize" (info cat $ progDesc "Add or remove package from category") @@ -362,28 +413,32 @@ parsePkgCat = subparser $ command "categorize" (info cat $ progDesc "Add or remo cat :: Parser Command cat = let cmd rm = if not rm then CmdPkgCatAdd else CmdPkgCatDel - in cmd + in cmd <$> switch (long "remove") <*> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME") <*> strArgument (metavar "PACKAGE_ID") <*> strArgument (metavar "CATEGORY") + opts :: ParserInfo Command opts = info (parseCommand <**> helper) (fullDesc <> progDesc "Publish tool for Embassy Packages") + cliMain :: IO () -cliMain = execParser opts >>= \case - CmdInit sh -> init sh - CmdRegAdd s pcr -> regAdd s pcr - CmdRegDel s -> regRm s - CmdRegList -> regLs - CmdUpload up -> upload up - CmdIndex name pkg v shouldIndex -> if shouldIndex then index name pkg v else deindex name pkg v - CmdListUnindexed name -> listUnindexed name - CmdCatAdd target cat desc pri -> catAdd target cat desc pri - CmdCatDel target cat -> catDel target cat - CmdPkgCatAdd target pkg cat -> pkgCatAdd target pkg cat - CmdPkgCatDel target pkg cat -> pkgCatDel target pkg cat +cliMain = + execParser opts >>= \case + CmdInit sh -> init sh + CmdRegAdd s pcr -> regAdd s pcr + CmdRegDel s -> regRm s + CmdRegList -> regLs + CmdUpload up -> upload up + CmdIndex name pkg v shouldIndex -> if shouldIndex then index name pkg v else deindex name pkg v + CmdListUnindexed name -> listUnindexed name + CmdCatAdd target cat desc pri -> catAdd target cat desc pri + CmdCatDel target cat -> catDel target cat + CmdPkgCatAdd target pkg cat -> pkgCatAdd target pkg cat + CmdPkgCatDel target pkg cat -> pkgCatDel target pkg cat + init :: Maybe Shell -> IO () init sh = do @@ -405,10 +460,9 @@ init sh = do writeFile zshcompleter (toS res) - regAdd :: String -> PublishCfgRepo -> IO () regAdd name val = do - loc <- cfgLocation + loc <- cfgLocation PublishCfg cfg <- inputFile Dhall.auto loc let cfg' = insert name val cfg writeFile loc (pretty $ embed inject $ PublishCfg cfg') @@ -423,16 +477,18 @@ regAdd name val = do . mappend "start9_admin:" $ publishCfgRepoPass val + regRm :: String -> IO () regRm name = do - loc <- cfgLocation + loc <- cfgLocation PublishCfg cfg <- inputFile Dhall.auto loc let cfg' = delete name cfg writeFile loc (pretty $ embed inject $ PublishCfg cfg') + regLs :: IO () regLs = do - loc <- cfgLocation + loc <- cfgLocation PublishCfg cfg <- inputFile Dhall.auto loc void $ traverseWithKey f cfg where @@ -440,19 +496,20 @@ regLs = do putChunk $ fromString (k <> ": ") & fore yellow putChunkLn $ fromString (show $ publishCfgRepoLocation v) & fore magenta + upload :: Upload -> IO () upload (Upload name mpkg shouldIndex) = do - PublishCfgRepo {..} <- findNameInCfg name - pkg <- case mpkg of + PublishCfgRepo{..} <- findNameInCfg name + pkg <- case mpkg of Nothing -> do - cwd <- getCurrentDirectory + cwd <- getCurrentDirectory files <- listDirectory cwd let pkgs = filter (\n -> takeExtension n == ".s9pk") files case pkgs of [] -> do $logError "No package specified, and could not find one in this directory" exitWith $ ExitFailure 1 - [p ] -> pure (cwd p) + [p] -> pure (cwd p) (_ : _ : _) -> do $logWarn "Ambiguous package upload request, found multiple candidates:" for_ pkgs $ \f -> $logWarn (fromString f) @@ -460,25 +517,25 @@ upload (Upload name mpkg shouldIndex) = do Just s -> pure s noBody <- parseRequest ("POST " <> show publishCfgRepoLocation <> "/admin/v0/upload") - <&> setRequestHeaders [("accept", "text/plain")] - <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass) + <&> setRequestHeaders [("accept", "text/plain")] + <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass) size <- getFileSize pkg - bar <- newProgressBar defStyle 30 (Progress 0 (fromIntegral size) ()) + bar <- newProgressBar defStyle 30 (Progress 0 (fromIntegral size) ()) body <- observedStreamFile (updateProgress bar . const . sfs2prog) pkg let withBody = setRequestBody body noBody manager <- newTlsManager - res <- runReaderT (httpLbs withBody) manager + res <- runReaderT (httpLbs withBody) manager if getResponseStatus res == status200 - -- no output is successful - then pure () + then -- no output is successful + pure () else do $logError (decodeUtf8 . LB.toStrict $ getResponseBody res) exitWith $ ExitFailure 1 putChunkLn $ fromString ("Successfully uploaded " <> pkg) & fore green when shouldIndex $ do - home <- getHomeDirectory + home <- getHomeDirectory manifestBytes <- sourceManifest (home ".cargo/bin") pkg $ \c -> runConduit (c .| foldC) - PackageManifest { packageManifestId, packageManifestVersion } <- case eitherDecodeStrict manifestBytes of + PackageManifest{packageManifestId, packageManifestVersion} <- case eitherDecodeStrict manifestBytes of Left s -> do $logError $ "Could not parse the manifest of the package: " <> toS s exitWith $ ExitFailure 1 @@ -486,45 +543,53 @@ upload (Upload name mpkg shouldIndex) = do let pkgId = toS $ unPkgId packageManifestId index name pkgId packageManifestVersion putChunkLn $ fromString ("Successfully indexed " <> pkgId <> "@" <> show packageManifestVersion) & fore green - where sfs2prog :: StreamFileStatus -> Progress () - sfs2prog StreamFileStatus {..} = Progress (fromIntegral readSoFar) (fromIntegral fileSize) () + sfs2prog StreamFileStatus{..} = Progress (fromIntegral readSoFar) (fromIntegral fileSize) () + index :: String -> String -> Version -> IO () index name pkg v = performHttp name "POST" [i|/admin/v0/index|] (IndexPkgReq (PkgId $ toS pkg) v) + deindex :: String -> String -> Version -> IO () deindex name pkg v = performHttp name "POST" [i|/admin/v0/deindex|] (IndexPkgReq (PkgId $ toS pkg) v) + listUnindexed :: String -> IO () listUnindexed name = do - PublishCfgRepo {..} <- findNameInCfg name - noBody <- + PublishCfgRepo{..} <- findNameInCfg name + noBody <- parseRequest (show publishCfgRepoLocation <> "/admin/v0/deindex") - <&> setRequestHeaders [("accept", "application/json")] - <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass) - PackageList {..} <- getResponseBody <$> httpJSON noBody - void $ flip traverseWithKey unPackageList $ \k v -> do - putChunk (chunk (unPkgId k <> ": ") & fore blue) - putChunkLn $ chunk (show v) & fore yellow + <&> setRequestHeaders [("accept", "application/json")] + <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass) + PackageList{..} <- getResponseBody <$> httpJSON noBody + void $ + flip traverseWithKey unPackageList $ \k v -> do + putChunk (chunk (unPkgId k <> ": ") & fore blue) + putChunkLn $ chunk (show v) & fore yellow + catAdd :: String -> String -> Maybe String -> Maybe Int -> IO () catAdd target name desc pri = performHttp target "POST" [i|/admin/v0/category/#{name}|] (AddCategoryReq (toS <$> desc) pri) + catDel :: String -> String -> IO () catDel target name = performHttp target "DELETE" [i|/admin/v0/category/#{name}|] () + pkgCatAdd :: String -> PkgId -> String -> IO () pkgCatAdd target pkg cat = performHttp target "POST" [i|/admin/v0/categorize/#{cat}/#{pkg}|] () + pkgCatDel :: String -> PkgId -> String -> IO () pkgCatDel target pkg cat = performHttp target "DELETE" [i|/admin/v0/categorize/#{cat}/#{pkg}|] () + findNameInCfg :: String -> IO PublishCfgRepo findNameInCfg name = do - loc <- cfgLocation + loc <- cfgLocation PublishCfg cfg <- inputFile Dhall.auto loc case lookup name cfg of Nothing -> do @@ -532,13 +597,14 @@ findNameInCfg name = do exitWith $ ExitFailure 1 Just pcr -> pure pcr + performHttp :: ToJSON a => String -> String -> String -> a -> IO () performHttp target method route body = do - PublishCfgRepo {..} <- findNameInCfg target - noBody <- + PublishCfgRepo{..} <- findNameInCfg target + noBody <- parseRequest (method <> " " <> show publishCfgRepoLocation <> route) - <&> setRequestHeaders [("accept", "text/plain")] - <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass) + <&> setRequestHeaders [("accept", "text/plain")] + <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass) let withBody = setRequestBodyJSON body noBody res <- httpLBS withBody if getResponseStatus res == status200 @@ -549,12 +615,13 @@ performHttp target method route body = do instance MonadLogger IO where - monadLoggerLog _ _ LevelDebug = putChunkLn . colorLog white - monadLoggerLog _ _ LevelInfo = putChunkLn . colorLog blue - monadLoggerLog _ _ LevelWarn = putChunkLn . colorLog yellow - monadLoggerLog _ _ LevelError = putChunkLn . colorLog red + monadLoggerLog _ _ LevelDebug = putChunkLn . colorLog white + monadLoggerLog _ _ LevelInfo = putChunkLn . colorLog blue + monadLoggerLog _ _ LevelWarn = putChunkLn . colorLog yellow + monadLoggerLog _ _ LevelError = putChunkLn . colorLog red monadLoggerLog _ _ (LevelOther _) = putChunkLn . colorLog magenta + colorLog :: ToLogStr msg => Radiant -> msg -> Chunk colorLog c m = fore c $ chunk . decodeUtf8 . fromLogStr . toLogStr $ m instance MonadLoggerIO IO where diff --git a/src/Database/Queries.hs b/src/Database/Queries.hs index d5a6064..34d58a9 100644 --- a/src/Database/Queries.hs +++ b/src/Database/Queries.hs @@ -10,8 +10,7 @@ import Database.Persist.Sql ( PersistStoreWrite (insertKey, insert_, repsert), SqlBackend, ) -import Lib.Types.AppIndex ( - PackageManifest (..), +import Lib.Types.Core ( PkgId, ) import Lib.Types.Emver (Version) @@ -81,6 +80,7 @@ import Database.Persist.Postgresql ( Entity (entityVal), runSqlPool, ) +import Lib.Types.Manifest (PackageManifest (..)) import Model ( Category, EntityField ( diff --git a/src/Foundation.hs b/src/Foundation.hs index a995bf0..b84c739 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -111,7 +111,7 @@ import Lib.PkgRepository ( EosRepo, PkgRepo, ) -import Lib.Types.AppIndex (PkgId, S9PK) +import Lib.Types.Core (PkgId, S9PK) import Model ( Admin (..), Key (AdminKey), diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 4fe3e48..7d60d15 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -62,11 +62,11 @@ import Lib.PkgRepository ( getPackages, getVersionsFor, ) -import Lib.Types.AppIndex ( - PackageManifest (..), +import Lib.Types.Core ( PkgId (unPkgId), ) import Lib.Types.Emver (Version (..)) +import Lib.Types.Manifest (PackageManifest (..)) import Model ( Category (..), Key (AdminKey, PkgRecordKey, VersionRecordKey), diff --git a/src/Handler/Package.hs b/src/Handler/Package.hs index 25847b6..294d48c 100644 --- a/src/Handler/Package.hs +++ b/src/Handler/Package.hs @@ -12,7 +12,7 @@ import Handler.Package.V0.ReleaseNotes (ReleaseNotes, getReleaseNotesR) import Handler.Package.V0.S9PK qualified import Handler.Package.V0.Version (AppVersionRes, getPkgVersionR) import Handler.Types.Api (ApiVersion (..)) -import Lib.Types.AppIndex (PkgId, S9PK) +import Lib.Types.Core (PkgId, S9PK) import Yesod.Core.Types ( JSONResponse, TypedContent, diff --git a/src/Handler/Package/V0/Icon.hs b/src/Handler/Package/V0/Icon.hs index f3ee362..352a5de 100644 --- a/src/Handler/Package/V0/Icon.hs +++ b/src/Handler/Package/V0/Icon.hs @@ -14,7 +14,7 @@ import Handler.Util ( ) import Lib.Error (S9Error (..)) import Lib.PkgRepository (getBestVersion, getIcon) -import Lib.Types.AppIndex (PkgId) +import Lib.Types.Core (PkgId) import Network.HTTP.Types (status400) import Startlude (show, ($)) import Yesod (TypedContent, addHeader, respondSource, sendChunkBS, sendResponseStatus) diff --git a/src/Handler/Package/V0/Index.hs b/src/Handler/Package/V0/Index.hs index 2a220c5..5df0991 100644 --- a/src/Handler/Package/V0/Index.hs +++ b/src/Handler/Package/V0/Index.hs @@ -30,7 +30,7 @@ import Handler.Types.Api (ApiVersion (..)) import Handler.Util (basicRender) import Lib.Error (S9Error (..)) import Lib.PkgRepository (PkgRepo, getIcon, getManifest) -import Lib.Types.AppIndex (PkgId) +import Lib.Types.Core (PkgId) import Lib.Types.Emver (Version, VersionRange (..), parseRange, satisfies, (<||)) import Model (Category (..), Key (..), PkgDependency (..), VersionRecord (..)) import Network.HTTP.Types (status400) diff --git a/src/Handler/Package/V0/Instructions.hs b/src/Handler/Package/V0/Instructions.hs index d7914e0..334d0e7 100644 --- a/src/Handler/Package/V0/Instructions.hs +++ b/src/Handler/Package/V0/Instructions.hs @@ -8,7 +8,7 @@ import Foundation (Handler) import Handler.Util (getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin) import Lib.Error (S9Error (..)) import Lib.PkgRepository (getBestVersion, getInstructions) -import Lib.Types.AppIndex (PkgId) +import Lib.Types.Core (PkgId) import Network.HTTP.Types (status400) import Startlude (show, ($)) import Yesod (TypedContent, addHeader, respondSource, sendChunkBS, sendResponseStatus, typePlain) diff --git a/src/Handler/Package/V0/Latest.hs b/src/Handler/Package/V0/Latest.hs index bd098ef..70e63d9 100644 --- a/src/Handler/Package/V0/Latest.hs +++ b/src/Handler/Package/V0/Latest.hs @@ -8,7 +8,7 @@ import Data.List (lookup) import Database.Queries (fetchLatestApp) import Foundation (Handler) import Lib.Error (S9Error (..)) -import Lib.Types.AppIndex (PkgId) +import Lib.Types.Core (PkgId) import Lib.Types.Emver (Version) import Model (Key (..), VersionRecord (..)) import Network.HTTP.Types (status400) diff --git a/src/Handler/Package/V0/License.hs b/src/Handler/Package/V0/License.hs index 35221f9..b0fe763 100644 --- a/src/Handler/Package/V0/License.hs +++ b/src/Handler/Package/V0/License.hs @@ -8,7 +8,7 @@ import Foundation (Handler) import Handler.Util (getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin) import Lib.Error (S9Error (..)) import Lib.PkgRepository (getBestVersion, getLicense) -import Lib.Types.AppIndex (PkgId) +import Lib.Types.Core (PkgId) import Network.HTTP.Types (status400) import Startlude (show, ($)) import Yesod (TypedContent, addHeader, respondSource, sendChunkBS, sendResponseStatus, typePlain) diff --git a/src/Handler/Package/V0/Manifest.hs b/src/Handler/Package/V0/Manifest.hs index e0a543a..e5142df 100644 --- a/src/Handler/Package/V0/Manifest.hs +++ b/src/Handler/Package/V0/Manifest.hs @@ -8,7 +8,7 @@ import Foundation (Handler) import Handler.Util (addPackageHeader, getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin) import Lib.Error (S9Error (..)) import Lib.PkgRepository (getBestVersion, getManifest) -import Lib.Types.AppIndex (PkgId) +import Lib.Types.Core (PkgId) import Network.HTTP.Types (status404) import Startlude (show, ($)) import Yesod (TypedContent, addHeader, respondSource, sendChunkBS, sendResponseStatus, typeJson) diff --git a/src/Handler/Package/V0/ReleaseNotes.hs b/src/Handler/Package/V0/ReleaseNotes.hs index 83ef00b..cd12db7 100644 --- a/src/Handler/Package/V0/ReleaseNotes.hs +++ b/src/Handler/Package/V0/ReleaseNotes.hs @@ -7,7 +7,7 @@ import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HM import Database.Queries (fetchAllAppVersions) import Foundation (Handler, RegistryCtx (..)) -import Lib.Types.AppIndex (PkgId) +import Lib.Types.Core (PkgId) import Lib.Types.Emver (Version) import Model (VersionRecord (..)) import Startlude (Down (..), Eq, Show, Text, fst, pure, sortOn, ($), (&&&), (.), (<$>)) diff --git a/src/Handler/Package/V0/S9PK.hs b/src/Handler/Package/V0/S9PK.hs index e58ea2a..8ac89d4 100644 --- a/src/Handler/Package/V0/S9PK.hs +++ b/src/Handler/Package/V0/S9PK.hs @@ -12,7 +12,7 @@ import GHC.Show (show) import Handler.Util (addPackageHeader, getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin) import Lib.Error (S9Error (..)) import Lib.PkgRepository (getBestVersion, getPackage) -import Lib.Types.AppIndex (PkgId (..), S9PK) +import Lib.Types.Core (PkgId (..), S9PK) import Lib.Types.Emver (Version (..)) import Network.HTTP.Types (status404) import Startlude (Maybe (..), pure, void, ($), (.), (>>=)) diff --git a/src/Handler/Package/V0/Version.hs b/src/Handler/Package/V0/Version.hs index 90fbc1c..5338cb6 100644 --- a/src/Handler/Package/V0/Version.hs +++ b/src/Handler/Package/V0/Version.hs @@ -12,7 +12,7 @@ import Handler.Util ( ) import Lib.Error (S9Error (..)) import Lib.PkgRepository (getBestVersion) -import Lib.Types.AppIndex (PkgId) +import Lib.Types.Core (PkgId) import Lib.Types.Emver (Version (..)) import Network.HTTP.Types (status404) import Startlude (Eq, Maybe, Show, (.), (<$>)) diff --git a/src/Handler/Util.hs b/src/Handler/Util.hs index 0eb9625..f9ca712 100644 --- a/src/Handler/Util.hs +++ b/src/Handler/Util.hs @@ -12,7 +12,7 @@ import Data.Text qualified as T import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Builder qualified as TB import Lib.PkgRepository (PkgRepo, getHash) -import Lib.Types.AppIndex (PkgId) +import Lib.Types.Core (PkgId) import Lib.Types.Emver ( Version, VersionRange, diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs index c861d99..4b5a701 100644 --- a/src/Lib/PkgRepository.hs +++ b/src/Lib/PkgRepository.hs @@ -1,180 +1,199 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} -{-# LANGUAGE GADTs #-} module Lib.PkgRepository where -import Conduit ( (.|) - , ConduitT - , MonadResource - , runConduit - , runResourceT - , sinkFileCautious - , sourceFile - ) -import Control.Monad.Logger ( MonadLogger - , MonadLoggerIO - , logError - , logInfo - , logWarn - ) -import Control.Monad.Reader.Has ( Has - , ask - , asks - ) -import Crypto.Hash ( SHA256 ) -import Crypto.Hash.Conduit ( hashFile ) -import Data.Aeson ( eitherDecodeFileStrict' ) -import qualified Data.Attoparsec.Text as Atto -import Data.Attoparsec.Text ( parseOnly ) -import Data.ByteArray.Encoding ( Base(Base16) - , convertToBase - ) -import Data.ByteString ( readFile - , writeFile - ) -import qualified Data.HashMap.Strict as HM -import Data.String.Interpolate.IsString - ( i ) -import qualified Data.Text as T -import Data.Time ( getCurrentTime ) -import Database.Esqueleto.Experimental - ( ConnectionPool - , insertUnique - , runSqlPool - ) -import Database.Persist ( (=.) - , insertKey - , update - , upsert - ) -import Database.Persist.Sql ( SqlPersistT - , runSqlPoolNoTransaction - ) -import Database.PostgreSQL.Simple ( SqlError(sqlState) ) -import Lib.Error ( S9Error(NotFoundE) ) -import qualified Lib.External.AppMgr as AppMgr -import Lib.Types.AppIndex ( PackageDependency(..) - , PackageManifest(..) - , PkgId(..) - , packageDependencyVersion - , packageManifestDependencies - ) -import Lib.Types.Emver ( Version - , VersionRange - , parseVersion - , satisfies - ) -import Model ( EntityField(EosHashHash, PkgRecordUpdatedAt) - , EosHash(EosHash) - , Key(PkgRecordKey) - , PkgDependency(PkgDependency) - , PkgRecord(PkgRecord) - ) -import Startlude ( ($) - , (&&) - , (.) - , (/=) - , (<$>) - , Bool(..) - , ByteString - , Down(..) - , Either(..) - , Eq((==)) - , Exception - , FilePath - , IO - , Integer - , Maybe(..) - , MonadIO(liftIO) - , MonadReader - , Ord(compare) - , Show - , SomeException(..) - , decodeUtf8 - , filter - , find - , first - , flip - , for_ - , fst - , headMay - , not - , on - , partitionEithers - , pure - , show - , snd - , sortBy - , throwIO - , toS - , void - ) -import System.FSNotify ( ActionPredicate - , Event(..) - , eventPath - , watchTree - , withManager - ) -import System.FilePath ( (<.>) - , () - , takeBaseName - , takeDirectory - , takeExtension - , takeFileName - ) -import UnliftIO ( MonadUnliftIO - , askRunInIO - , async - , catch - , mapConcurrently_ - , newEmptyMVar - , takeMVar - , tryPutMVar - , wait - ) -import UnliftIO.Concurrent ( forkIO ) -import UnliftIO.Directory ( doesDirectoryExist - , doesPathExist - , getFileSize - , listDirectory - , removeFile - , renameFile - ) -import UnliftIO.Exception ( handle ) -import Yesod.Core.Content ( typeGif - , typeJpeg - , typePlain - , typePng - , typeSvg - ) -import Yesod.Core.Types ( ContentType ) +import Conduit ( + ConduitT, + MonadResource, + runConduit, + runResourceT, + sinkFileCautious, + sourceFile, + (.|), + ) +import Control.Monad.Logger ( + MonadLogger, + MonadLoggerIO, + logError, + logInfo, + logWarn, + ) +import Control.Monad.Reader.Has ( + Has, + ask, + asks, + ) +import Crypto.Hash (SHA256) +import Crypto.Hash.Conduit (hashFile) +import Data.Aeson (eitherDecodeFileStrict') +import Data.Attoparsec.Text (parseOnly) +import Data.Attoparsec.Text qualified as Atto +import Data.ByteArray.Encoding ( + Base (Base16), + convertToBase, + ) +import Data.ByteString ( + readFile, + writeFile, + ) +import Data.HashMap.Strict qualified as HM +import Data.String.Interpolate.IsString ( + i, + ) +import Data.Text qualified as T +import Data.Time (getCurrentTime) +import Database.Esqueleto.Experimental ( + ConnectionPool, + insertUnique, + runSqlPool, + ) +import Database.Persist ( + insertKey, + update, + upsert, + (=.), + ) +import Database.Persist.Sql ( + SqlPersistT, + runSqlPoolNoTransaction, + ) +import Database.PostgreSQL.Simple (SqlError (sqlState)) +import Lib.Error (S9Error (NotFoundE)) +import Lib.External.AppMgr qualified as AppMgr +import Lib.Types.Core ( + PkgId (..), + ) +import Lib.Types.Emver ( + Version, + VersionRange, + parseVersion, + satisfies, + ) +import Lib.Types.Manifest (PackageDependency (..), PackageManifest (..)) +import Model ( + EntityField (EosHashHash, PkgRecordUpdatedAt), + EosHash (EosHash), + Key (PkgRecordKey), + PkgDependency (PkgDependency), + PkgRecord (PkgRecord), + ) +import Startlude ( + Bool (..), + ByteString, + Down (..), + Either (..), + Eq ((==)), + Exception, + FilePath, + IO, + Integer, + Maybe (..), + MonadIO (liftIO), + MonadReader, + Ord (compare), + Show, + SomeException (..), + decodeUtf8, + filter, + find, + first, + flip, + for_, + fst, + headMay, + not, + on, + partitionEithers, + pure, + show, + snd, + sortBy, + throwIO, + toS, + void, + ($), + (&&), + (.), + (/=), + (<$>), + ) +import System.FSNotify ( + ActionPredicate, + Event (..), + eventPath, + watchTree, + withManager, + ) +import System.FilePath ( + takeBaseName, + takeDirectory, + takeExtension, + takeFileName, + (<.>), + (), + ) +import UnliftIO ( + MonadUnliftIO, + askRunInIO, + async, + catch, + mapConcurrently_, + newEmptyMVar, + takeMVar, + tryPutMVar, + wait, + ) +import UnliftIO.Concurrent (forkIO) +import UnliftIO.Directory ( + doesDirectoryExist, + doesPathExist, + getFileSize, + listDirectory, + removeFile, + renameFile, + ) +import UnliftIO.Exception (handle) +import Yesod.Core.Content ( + typeGif, + typeJpeg, + typePlain, + typePng, + typeSvg, + ) +import Yesod.Core.Types (ContentType) + newtype ManifestParseException = ManifestParseException FilePath - deriving Show + deriving (Show) instance Exception ManifestParseException + data PkgRepo = PkgRepo - { pkgRepoFileRoot :: !FilePath + { pkgRepoFileRoot :: !FilePath , pkgRepoAppMgrBin :: !FilePath } + newtype EosRepo = EosRepo { eosRepoFileRoot :: FilePath } + getPackages :: (MonadIO m, MonadReader r m, Has PkgRepo r) => m [PkgId] getPackages = do - root <- asks pkgRepoFileRoot + root <- asks pkgRepoFileRoot paths <- listDirectory root pure $ PkgId . toS <$> paths + getVersionsFor :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) => PkgId -> m [Version] getVersionsFor pkg = do root <- asks pkgRepoFileRoot @@ -188,52 +207,66 @@ getVersionsFor pkg = do pure successes else pure [] + getViableVersions :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) => PkgId -> VersionRange -> m [Version] getViableVersions pkg spec = filter (`satisfies` spec) <$> getVersionsFor pkg -getBestVersion :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) - => PkgId - -> VersionRange - -> Bool - -> m (Maybe Version) + +getBestVersion :: + (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) => + PkgId -> + VersionRange -> + Bool -> + m (Maybe Version) getBestVersion pkg spec preferMin = headMay . sortBy comparator <$> getViableVersions pkg spec - where comparator = if preferMin then compare else compare `on` Down + where + comparator = if preferMin then compare else compare `on` Down + loadPkgDependencies :: MonadUnliftIO m => ConnectionPool -> PackageManifest -> m () loadPkgDependencies appConnPool manifest = do - let pkgId = packageManifestId manifest + let pkgId = packageManifestId manifest let pkgVersion = packageManifestVersion manifest - let deps = packageManifestDependencies manifest + let deps = packageManifestDependencies manifest time <- liftIO getCurrentTime - _ <- runWith appConnPool $ insertKey (PkgRecordKey pkgId) (PkgRecord time Nothing) `catch` \(e :: SqlError) -> - -- 23505 is "already exists" - if sqlState e == "23505" then update (PkgRecordKey pkgId) [PkgRecordUpdatedAt =. Just time] else throwIO e + _ <- + runWith appConnPool $ + insertKey (PkgRecordKey pkgId) (PkgRecord time Nothing) `catch` \(e :: SqlError) -> + -- 23505 is "already exists" + if sqlState e == "23505" then update (PkgRecordKey pkgId) [PkgRecordUpdatedAt =. Just time] else throwIO e let deps' = first PkgRecordKey <$> HM.toList deps for_ deps' - (\d -> flip runSqlPool appConnPool $ do - _ <- runWith appConnPool $ insertKey (fst d) (PkgRecord time Nothing) `catch` \(e :: SqlError) -> - -- 23505 is "already exists" - if sqlState e == "23505" then update (fst d) [PkgRecordUpdatedAt =. Just time] else throwIO e - insertUnique - $ PkgDependency time (PkgRecordKey pkgId) pkgVersion (fst d) (packageDependencyVersion . snd $ d) + ( \d -> flip runSqlPool appConnPool $ do + _ <- + runWith appConnPool $ + insertKey (fst d) (PkgRecord time Nothing) `catch` \(e :: SqlError) -> + -- 23505 is "already exists" + if sqlState e == "23505" then update (fst d) [PkgRecordUpdatedAt =. Just time] else throwIO e + insertUnique $ + PkgDependency time (PkgRecordKey pkgId) pkgVersion (fst d) (packageDependencyVersion . snd $ d) ) where runWith :: MonadUnliftIO m => ConnectionPool -> SqlPersistT m a -> m a runWith pool action = runSqlPoolNoTransaction action pool Nothing + -- extract all package assets into their own respective files extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => ConnectionPool -> FilePath -> m () extractPkg pool fp = handle @_ @SomeException cleanup $ do $logInfo [i|Extracting package: #{fp}|] - PkgRepo { pkgRepoAppMgrBin = appmgr } <- ask + PkgRepo{pkgRepoAppMgrBin = appmgr} <- ask let pkgRoot = takeDirectory fp - manifestTask <- async $ runResourceT $ AppMgr.sourceManifest appmgr fp $ sinkIt (pkgRoot "manifest.json") - pkgHashTask <- async $ AppMgr.getPackageHash appmgr fp - instructionsTask <- async $ runResourceT $ AppMgr.sourceInstructions appmgr fp $ sinkIt - (pkgRoot "instructions.md") + manifestTask <- async $ runResourceT $ AppMgr.sourceManifest appmgr fp $ sinkIt (pkgRoot "manifest.json") + pkgHashTask <- async $ AppMgr.getPackageHash appmgr fp + instructionsTask <- + async $ + runResourceT $ + AppMgr.sourceInstructions appmgr fp $ + sinkIt + (pkgRoot "instructions.md") licenseTask <- async $ runResourceT $ AppMgr.sourceLicense appmgr fp $ sinkIt (pkgRoot "license.md") - iconTask <- async $ runResourceT $ AppMgr.sourceIcon appmgr fp $ sinkIt (pkgRoot "icon.tmp") + iconTask <- async $ runResourceT $ AppMgr.sourceIcon appmgr fp $ sinkIt (pkgRoot "icon.tmp") wait manifestTask eManifest <- liftIO (eitherDecodeFileStrict' (pkgRoot "manifest.json")) case eManifest of @@ -242,11 +275,12 @@ extractPkg pool fp = handle @_ @SomeException cleanup $ do liftIO . throwIO $ ManifestParseException (pkgRoot "manifest.json") Right manifest -> do wait iconTask - let iconDest = "icon" <.> case packageManifestIcon manifest of - Nothing -> "png" - Just x -> case takeExtension (T.unpack x) of - "" -> "png" - other -> other + let iconDest = + "icon" <.> case packageManifestIcon manifest of + Nothing -> "png" + Just x -> case takeExtension (T.unpack x) of + "" -> "png" + other -> other loadPkgDependencies pool manifest liftIO $ renameFile (pkgRoot "icon.tmp") (pkgRoot iconDest) hash <- wait pkgHashTask @@ -263,97 +297,112 @@ extractPkg pool fp = handle @_ @SomeException cleanup $ do mapConcurrently_ (removeFile . (pkgRoot )) toRemove throwIO e + watchEosRepoRoot :: (MonadUnliftIO m, MonadReader r m, Has EosRepo r, MonadLoggerIO m) => ConnectionPool -> m (IO Bool) watchEosRepoRoot pool = do $logInfo "Starting FSNotify Watch Manager: EOS" - root <- asks eosRepoFileRoot + root <- asks eosRepoFileRoot runInIO <- askRunInIO - box <- newEmptyMVar @_ @() - _ <- forkIO $ liftIO $ withManager $ \watchManager -> do - stop <- watchTree watchManager root shouldIndex $ \evt -> do - let os = eventPath evt - void . forkIO $ runInIO $ do - indexOs pool os - takeMVar box - stop + box <- newEmptyMVar @_ @() + _ <- forkIO $ + liftIO $ + withManager $ \watchManager -> do + stop <- watchTree watchManager root shouldIndex $ \evt -> do + let os = eventPath evt + void . forkIO $ + runInIO $ do + indexOs pool os + takeMVar box + stop pure $ tryPutMVar box () where shouldIndex :: ActionPredicate - shouldIndex (Added path _ isDir) = not isDir && takeExtension path == ".img" + shouldIndex (Added path _ isDir) = not isDir && takeExtension path == ".img" shouldIndex (Modified path _ isDir) = not isDir && takeExtension path == ".img" - shouldIndex _ = False + shouldIndex _ = False indexOs :: (MonadUnliftIO m, MonadLoggerIO m) => ConnectionPool -> FilePath -> m () indexOs pool path = do hash <- hashFile @_ @SHA256 path let hashText = decodeUtf8 $ convertToBase Base16 hash - let vText = takeFileName (takeDirectory path) + let vText = takeFileName (takeDirectory path) let eVersion = parseOnly parseVersion . T.pack $ vText case eVersion of Left e -> $logError [i|Invalid Version Number (#{vText}): #{e}|] Right version -> void $ flip runSqlPool pool $ upsert (EosHash version hashText) [EosHashHash =. hashText] + getManifestLocation :: (MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m FilePath getManifestLocation pkg version = do root <- asks pkgRepoFileRoot pure $ root show pkg show version "manifest.json" -getManifest :: (MonadResource m, MonadReader r m, Has PkgRepo r) - => PkgId - -> Version - -> m (Integer, ConduitT () ByteString m ()) + +getManifest :: + (MonadResource m, MonadReader r m, Has PkgRepo r) => + PkgId -> + Version -> + m (Integer, ConduitT () ByteString m ()) getManifest pkg version = do manifestPath <- getManifestLocation pkg version - n <- getFileSize manifestPath + n <- getFileSize manifestPath pure (n, sourceFile manifestPath) -getInstructions :: (MonadResource m, MonadReader r m, Has PkgRepo r) - => PkgId - -> Version - -> m (Integer, ConduitT () ByteString m ()) + +getInstructions :: + (MonadResource m, MonadReader r m, Has PkgRepo r) => + PkgId -> + Version -> + m (Integer, ConduitT () ByteString m ()) getInstructions pkg version = do root <- asks pkgRepoFileRoot let instructionsPath = root show pkg show version "instructions.md" n <- getFileSize instructionsPath pure (n, sourceFile instructionsPath) -getLicense :: (MonadResource m, MonadReader r m, Has PkgRepo r) - => PkgId - -> Version - -> m (Integer, ConduitT () ByteString m ()) + +getLicense :: + (MonadResource m, MonadReader r m, Has PkgRepo r) => + PkgId -> + Version -> + m (Integer, ConduitT () ByteString m ()) getLicense pkg version = do root <- asks pkgRepoFileRoot let licensePath = root show pkg show version "license.md" n <- getFileSize licensePath pure (n, sourceFile licensePath) -getIcon :: (MonadResource m, MonadReader r m, Has PkgRepo r) - => PkgId - -> Version - -> m (ContentType, Integer, ConduitT () ByteString m ()) + +getIcon :: + (MonadResource m, MonadReader r m, Has PkgRepo r) => + PkgId -> + Version -> + m (ContentType, Integer, ConduitT () ByteString m ()) getIcon pkg version = do root <- asks pkgRepoFileRoot let pkgRoot = root show pkg show version mIconFile <- find ((== "icon") . takeBaseName) <$> listDirectory pkgRoot case mIconFile of Nothing -> throwIO $ NotFoundE [i|#{pkg}: Icon|] - Just x -> do + Just x -> do let ct = case takeExtension x of - ".png" -> typePng - ".jpg" -> typeJpeg + ".png" -> typePng + ".jpg" -> typeJpeg ".jpeg" -> typeJpeg - ".svg" -> typeSvg - ".gif" -> typeGif - _ -> typePlain + ".svg" -> typeSvg + ".gif" -> typeGif + _ -> typePlain n <- getFileSize (pkgRoot x) pure (ct, n, sourceFile (pkgRoot x)) + getHash :: (MonadIO m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m ByteString getHash pkg version = do root <- asks pkgRepoFileRoot let hashPath = root show pkg show version "hash.bin" liftIO $ readFile hashPath + getPackage :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m (Maybe FilePath) getPackage pkg version = do root <- asks pkgRepoFileRoot diff --git a/src/Lib/Types/Core.hs b/src/Lib/Types/Core.hs new file mode 100644 index 0000000..fe563fa --- /dev/null +++ b/src/Lib/Types/Core.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} + +module Lib.Types.Core where + +import Startlude ( + ConvertText (toS), + Either (Left, Right), + Eq ((==)), + Functor (fmap), + Hashable (hashWithSalt), + IsString (..), + KnownSymbol, + Ord, + Proxy (Proxy), + Read, + Show, + String, + Symbol, + Text, + readMaybe, + show, + symbolVal, + ($), + (.), + ) + +import Data.Aeson ( + FromJSON (..), + FromJSONKey (..), + ToJSON (..), + ToJSONKey (..), + ) +import Data.Functor.Contravariant (contramap) +import Data.String.Interpolate.IsString ( + i, + ) +import Database.Persist ( + PersistField (..), + PersistValue (PersistText), + SqlType (..), + ) +import Database.Persist.Sql (PersistFieldSql (sqlType)) +import GHC.Read (Read (readsPrec)) +import Orphans.Emver () +import Protolude.Base qualified as P ( + Show (..), + ) +import System.FilePath (splitExtension, (<.>)) +import Web.HttpApiData ( + FromHttpApiData, + ToHttpApiData, + ) +import Yesod (PathPiece (..)) + + +newtype PkgId = PkgId {unPkgId :: Text} + deriving stock (Eq, Ord) + deriving newtype (FromHttpApiData, ToHttpApiData) +instance IsString PkgId where + fromString = PkgId . fromString +instance P.Show PkgId where + show = toS . unPkgId +instance Read PkgId where + readsPrec _ s = [(PkgId $ toS s, "")] +instance Hashable PkgId where + hashWithSalt n = hashWithSalt n . unPkgId +instance FromJSON PkgId where + parseJSON = fmap PkgId . parseJSON +instance ToJSON PkgId where + toJSON = toJSON . unPkgId +instance FromJSONKey PkgId where + fromJSONKey = fmap PkgId fromJSONKey +instance ToJSONKey PkgId where + toJSONKey = contramap unPkgId toJSONKey +instance PersistField PkgId where + toPersistValue = PersistText . show + fromPersistValue (PersistText t) = Right . PkgId $ toS t + fromPersistValue other = Left [i|Invalid AppId: #{other}|] +instance PersistFieldSql PkgId where + sqlType _ = SqlString +instance PathPiece PkgId where + fromPathPiece = fmap PkgId . fromPathPiece + toPathPiece = unPkgId + + +newtype Extension (a :: Symbol) = Extension String deriving (Eq) +type S9PK = Extension "s9pk" +instance KnownSymbol a => Show (Extension a) where + show e@(Extension file) = file <.> extension e +instance KnownSymbol a => Read (Extension a) where + readsPrec _ s = case symbolVal $ Proxy @a of + "" -> [(Extension s, "")] + other -> [(Extension file, "") | ext' == "" <.> other] + where + (file, ext') = splitExtension s +instance KnownSymbol a => PathPiece (Extension a) where + fromPathPiece = readMaybe . toS + toPathPiece = show + + +extension :: KnownSymbol a => Extension a -> String +extension = symbolVal \ No newline at end of file diff --git a/src/Lib/Types/AppIndex.hs b/src/Lib/Types/Manifest.hs similarity index 62% rename from src/Lib/Types/AppIndex.hs rename to src/Lib/Types/Manifest.hs index 0eb8de4..dc45c5c 100644 --- a/src/Lib/Types/AppIndex.hs +++ b/src/Lib/Types/Manifest.hs @@ -1,108 +1,20 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -module Lib.Types.AppIndex where +module Lib.Types.Manifest where -import Startlude - --- NOTE: leave eitherDecode for inline test evaluation below -import Control.Monad (fail) -import Data.Aeson ( - FromJSON (..), - FromJSONKey (..), - ToJSON (..), - ToJSONKey (..), - withObject, - (.:), - (.:?), - ) -import Data.ByteString.Lazy qualified as BS -import Data.Functor.Contravariant (contramap) +import Control.Monad.Fail (MonadFail (..)) +import Data.Aeson (FromJSON (..), withObject, (.:), (.:?)) +import Data.HashMap.Internal.Strict (HashMap) import Data.HashMap.Strict qualified as HM -import Data.String.Interpolate.IsString ( - i, - ) +import Data.String.Interpolate.IsString (i) import Data.Text qualified as T -import Database.Persist ( - PersistField (..), - PersistValue (PersistText), - SqlType (..), - ) -import Database.Persist.Sql (PersistFieldSql (sqlType)) -import GHC.Read (Read (readsPrec)) -import Lib.Types.Emver ( - Version, - VersionRange, - ) -import Orphans.Emver () -import Protolude.Base qualified as P ( - Show (..), - ) -import System.FilePath (splitExtension, (<.>)) -import Web.HttpApiData ( - FromHttpApiData, - ToHttpApiData, - ) -import Yesod (PathPiece (..)) +import Lib.Types.Core (PkgId) +import Lib.Types.Emver (Version (..), VersionRange) +import Startlude (ByteString, Eq, Generic, Hashable, Maybe (..), Monad ((>>=)), Read, Show, Text, for, pure, readMaybe, ($)) -newtype PkgId = PkgId {unPkgId :: Text} - deriving stock (Eq, Ord) - deriving newtype (FromHttpApiData, ToHttpApiData) -instance IsString PkgId where - fromString = PkgId . fromString -instance P.Show PkgId where - show = toS . unPkgId -instance Read PkgId where - readsPrec _ s = [(PkgId $ toS s, "")] -instance Hashable PkgId where - hashWithSalt n = hashWithSalt n . unPkgId -instance FromJSON PkgId where - parseJSON = fmap PkgId . parseJSON -instance ToJSON PkgId where - toJSON = toJSON . unPkgId -instance FromJSONKey PkgId where - fromJSONKey = fmap PkgId fromJSONKey -instance ToJSONKey PkgId where - toJSONKey = contramap unPkgId toJSONKey -instance PersistField PkgId where - toPersistValue = PersistText . show - fromPersistValue (PersistText t) = Right . PkgId $ toS t - fromPersistValue other = Left [i|Invalid AppId: #{other}|] -instance PersistFieldSql PkgId where - sqlType _ = SqlString -instance PathPiece PkgId where - fromPathPiece = fmap PkgId . fromPathPiece - toPathPiece = unPkgId -data VersionInfo = VersionInfo - { versionInfoVersion :: !Version - , versionInfoReleaseNotes :: !Text - , versionInfoDependencies :: !(HM.HashMap PkgId VersionRange) - , versionInfoOsVersion :: !Version - , versionInfoInstallAlert :: !(Maybe Text) - } - deriving (Eq, Show) - - -data PackageDependency = PackageDependency - { packageDependencyOptional :: !(Maybe Text) - , packageDependencyVersion :: !VersionRange - , packageDependencyDescription :: !(Maybe Text) - } - deriving (Show) -instance FromJSON PackageDependency where - parseJSON = withObject "service dependency info" $ \o -> do - packageDependencyOptional <- o .:? "optional" - packageDependencyVersion <- o .: "version" - packageDependencyDescription <- o .:? "description" - pure PackageDependency{..} -data ServiceAlert = INSTALL | UNINSTALL | RESTORE | START | STOP - deriving (Show, Eq, Generic, Hashable, Read) data PackageManifest = PackageManifest { packageManifestId :: !PkgId , packageManifestTitle :: !Text @@ -111,8 +23,8 @@ data PackageManifest = PackageManifest , packageManifestDescriptionShort :: !Text , packageManifestReleaseNotes :: !Text , packageManifestIcon :: !(Maybe Text) - , packageManifestAlerts :: !(HM.HashMap ServiceAlert (Maybe Text)) - , packageManifestDependencies :: !(HM.HashMap PkgId PackageDependency) + , packageManifestAlerts :: !(HashMap ServiceAlert (Maybe Text)) + , packageManifestDependencies :: !(HashMap PkgId PackageDependency) , packageManifestEosVersion :: !Version } deriving (Show) @@ -138,33 +50,26 @@ instance FromJSON PackageManifest where pure PackageManifest{..} -newtype Extension (a :: Symbol) = Extension String deriving (Eq) -type S9PK = Extension "s9pk" +data PackageDependency = PackageDependency + { packageDependencyOptional :: !(Maybe Text) + , packageDependencyVersion :: !VersionRange + , packageDependencyDescription :: !(Maybe Text) + } + deriving (Show) +instance FromJSON PackageDependency where + parseJSON = withObject "service dependency info" $ \o -> do + packageDependencyOptional <- o .:? "optional" + packageDependencyVersion <- o .: "version" + packageDependencyDescription <- o .:? "description" + pure PackageDependency{..} -extension :: KnownSymbol a => Extension a -> String -extension = symbolVal - - -instance KnownSymbol a => Show (Extension a) where - show e@(Extension file) = file <.> extension e - - -instance KnownSymbol a => Read (Extension a) where - readsPrec _ s = case symbolVal $ Proxy @a of - "" -> [(Extension s, "")] - other -> [(Extension file, "") | ext' == "" <.> other] - where - (file, ext') = splitExtension s - - -instance KnownSymbol a => PathPiece (Extension a) where - fromPathPiece = readMaybe . toS - toPathPiece = show +data ServiceAlert = INSTALL | UNINSTALL | RESTORE | START | STOP + deriving (Show, Eq, Generic, Hashable, Read) -- >>> eitherDecode testManifest :: Either String PackageManifest -testManifest :: BS.ByteString +testManifest :: ByteString testManifest = [i|{ "id": "embassy-pages", @@ -303,4 +208,4 @@ testManifest = "config": null } } -}|] +}|] \ No newline at end of file diff --git a/src/Model.hs b/src/Model.hs index f1d2888..95ea833 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -1,40 +1,47 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Model where -import Crypto.Hash ( Digest - , SHA256 - ) -import Database.Persist.TH ( mkMigrate - , mkPersist - , persistLowerCase - , share - , sqlSettings - ) -import Lib.Types.AppIndex ( PkgId(PkgId) ) -import Lib.Types.Emver ( Version - , VersionRange - ) -import Orphans.Cryptonite ( ) -import Orphans.Emver ( ) -import Startlude ( Eq - , Int - , Show - , Text - , UTCTime - , Word32 - ) +import Crypto.Hash ( + Digest, + SHA256, + ) +import Database.Persist.TH ( + mkMigrate, + mkPersist, + persistLowerCase, + share, + sqlSettings, + ) +import Lib.Types.Core (PkgId (PkgId)) +import Lib.Types.Emver ( + Version, + VersionRange, + ) +import Orphans.Cryptonite () +import Orphans.Emver () +import Startlude ( + Eq, + Int, + Show, + Text, + UTCTime, + Word32, + ) -share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| + +share + [mkPersist sqlSettings, mkMigrate "migrateAll"] + [persistLowerCase| PkgRecord Id PkgId sql=pkg_id createdAt UTCTime