Start9/registry
2
0
Fork 0
mirror of https://github.com/Start9Labs/registry.git synced 2026-03-30 19:54:47 +00:00
Code Issues Packages Projects Releases Wiki Activity

finished massive refactor

Browse Source
This commit is contained in:
Keagan McClelland
2022-06-09 17:11:37 -06:00
parent a18a136574
commit 4365fc1f9a
19 changed files with 807 additions and 671 deletions
Download Patch File Download Diff File Expand all files Collapse all files

647
src/Cli/Cli.hs
View File

@@ -8,199 +8,217 @@
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-orphans #-}
module Cli.Cli module Cli.Cli (
( cliMain cliMain,
) where ) 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 data Upload = Upload
{ publishRepoName :: !String { publishRepoName :: !String
, publishPkg :: !(Maybe FilePath) , publishPkg :: !(Maybe FilePath)
, publishIndex :: !Bool , publishIndex :: !Bool
} }
deriving Show deriving (Show)
newtype PublishCfg = PublishCfg newtype PublishCfg = PublishCfg
{ publishCfgRepos :: HashMap String PublishCfgRepo { publishCfgRepos :: HashMap String PublishCfgRepo
} }
deriving Generic deriving (Generic)
instance FromDhall PublishCfg instance FromDhall PublishCfg
instance ToDhall PublishCfg instance ToDhall PublishCfg
instance Default PublishCfg where instance Default PublishCfg where
@@ -209,23 +227,27 @@ instance Default PublishCfg where
data PublishCfgRepo = PublishCfgRepo data PublishCfgRepo = PublishCfgRepo
{ publishCfgRepoLocation :: !URI { publishCfgRepoLocation :: !URI
, publishCfgRepoUser :: !String , publishCfgRepoUser :: !String
, publishCfgRepoPass :: !String , publishCfgRepoPass :: !String
} }
deriving (Show, Generic) deriving (Show, Generic)
instance FromDhall PublishCfgRepo instance FromDhall PublishCfgRepo
instance ToDhall PublishCfgRepo instance ToDhall PublishCfgRepo
instance FromDhall URI where instance FromDhall URI where
autoWith norm = fromMaybe (panic "Invalid URI for publish target") . parseURI <$> autoWith norm autoWith norm = fromMaybe (panic "Invalid URI for publish target") . parseURI <$> autoWith norm
instance ToDhall URI where instance ToDhall URI where
injectWith norm = contramap (show @_ @String) (injectWith norm) injectWith norm = contramap (show @_ @String) (injectWith norm)
instance IsString URI where instance IsString URI where
fromString = fromMaybe (panic "Invalid URI for publish target") . parseURI 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 data Command
= CmdInit !(Maybe Shell) = CmdInit !(Maybe Shell)
| CmdRegAdd !String !PublishCfgRepo | CmdRegAdd !String !PublishCfgRepo
@@ -238,72 +260,89 @@ data Command
| CmdCatDel !String !String | CmdCatDel !String !String
| CmdPkgCatAdd !String !PkgId !String | CmdPkgCatAdd !String !PkgId !String
| CmdPkgCatDel !String !PkgId !String | CmdPkgCatDel !String !PkgId !String
deriving Show deriving (Show)
cfgLocation :: IO FilePath cfgLocation :: IO FilePath
cfgLocation = getHomeDirectory <&> \d -> d </> ".embassy/publish.dhall" cfgLocation = getHomeDirectory <&> \d -> d </> ".embassy/publish.dhall"
parseInit :: Parser (Maybe Shell) parseInit :: Parser (Maybe Shell)
parseInit = subparser $ command "init" (info go $ progDesc "Initializes embassy-publish config") <> metavar "init" parseInit = subparser $ command "init" (info go $ progDesc "Initializes embassy-publish config") <> metavar "init"
where where
shells = [Bash, Fish, Zsh] 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 :: Parser Upload
parsePublish = subparser $ command "upload" (info go $ progDesc "Publishes a .s9pk to a remote registry") <> metavar parsePublish =
"upload" subparser $
command "upload" (info go $ progDesc "Publishes a .s9pk to a remote registry")
<> metavar
"upload"
where where
go = liftA3 go =
Upload liftA3
(strOption (short 't' <> long "target" <> metavar "NAME" <> help "Name of registry in publish.dhall")) Upload
(optional $ strOption (strOption (short 't' <> long "target" <> metavar "NAME" <> help "Name of registry in publish.dhall"))
(short 'p' <> long "package" <> metavar "S9PK" <> help "File path of the package to publish") ( optional $
) strOption
(switch (short 'i' <> long "index" <> help "Index the package after uploading")) (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 :: Parser Command
parseRepoAdd = subparser $ command "add" (info go $ progDesc "Add a registry to your config") <> metavar "add" parseRepoAdd = subparser $ command "add" (info go $ progDesc "Add a registry to your config") <> metavar "add"
where where
go :: Parser Command go :: Parser Command
go = go =
let let publishCfgRepoLocation =
publishCfgRepoLocation =
strOption (short 'l' <> long "location" <> metavar "REGISTRY_URL" <> help "Registry URL") strOption (short 'l' <> long "location" <> metavar "REGISTRY_URL" <> help "Registry URL")
publishCfgRepoUser = strOption publishCfgRepoUser =
(short 'u' <> long "username" <> metavar "USERNAME" <> help "Admin username for this registry") strOption
publishCfgRepoPass = strOption (short 'u' <> long "username" <> metavar "USERNAME" <> help "Admin username for this registry")
(short 'p' <> long "password" <> metavar "PASSWORD" <> help "Admin password for this registry") publishCfgRepoPass =
strOption
(short 'p' <> long "password" <> metavar "PASSWORD" <> help "Admin password for this registry")
name = name =
strOption strOption
(short 'n' <> long "name" <> metavar "REGISTRY_NAME" <> help ( short 'n' <> long "name" <> metavar "REGISTRY_NAME"
"Name to reference this registry in the future" <> help
"Name to reference this registry in the future"
) )
r = PublishCfgRepo <$> publishCfgRepoLocation <*> publishCfgRepoUser <*> publishCfgRepoPass r = PublishCfgRepo <$> publishCfgRepoLocation <*> publishCfgRepoUser <*> publishCfgRepoPass
in in liftA2 CmdRegAdd name r
liftA2 CmdRegAdd name r
parseRepoDel :: Parser String parseRepoDel :: Parser String
parseRepoDel = subparser $ command "rm" (info go $ progDesc "Remove a registry from your config") <> metavar "rm" parseRepoDel = subparser $ command "rm" (info go $ progDesc "Remove a registry from your config") <> metavar "rm"
where where
go = strOption go =
(short 'n' <> long "name" <> metavar "REGISTRY_NAME" <> help strOption
"Registry name chosen when this was originally configured" ( short 'n' <> long "name" <> metavar "REGISTRY_NAME"
) <> help
"Registry name chosen when this was originally configured"
)
parseRepoList :: Parser () parseRepoList :: Parser ()
parseRepoList = subparser $ command "ls" (info (pure ()) $ progDesc "List registries in your config") <> metavar "ls" parseRepoList = subparser $ command "ls" (info (pure ()) $ progDesc "List registries in your config") <> metavar "ls"
parseIndex :: Parser Command parseIndex :: Parser Command
parseIndex = parseIndex =
subparser subparser $
$ command "index" (info (parseIndexHelper True) $ progDesc "Indexes an existing package version") command "index" (info (parseIndexHelper True) $ progDesc "Indexes an existing package version")
<> metavar "index" <> metavar "index"
parseDeindex :: Parser Command parseDeindex :: Parser Command
parseDeindex = parseDeindex =
subparser subparser $
$ command "deindex" (info (parseIndexHelper False) $ progDesc "Deindexes an existing package version") command "deindex" (info (parseIndexHelper False) $ progDesc "Deindexes an existing package version")
<> metavar "deindex" <> metavar "deindex"
parseIndexHelper :: Bool -> Parser Command parseIndexHelper :: Bool -> Parser Command
parseIndexHelper b = parseIndexHelper b =
@@ -313,12 +352,16 @@ parseIndexHelper b =
<*> strArgument (metavar "VERSION") <*> strArgument (metavar "VERSION")
<*> pure b <*> pure b
parseListUnindexed :: Parser String parseListUnindexed :: Parser String
parseListUnindexed = subparser $ command parseListUnindexed =
"list-unindexed" subparser $
( info (strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME")) command
$ progDesc "Lists unindexed package versions on target registry" "list-unindexed"
) ( info (strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME")) $
progDesc "Lists unindexed package versions on target registry"
)
parseCommand :: Parser Command parseCommand :: Parser Command
parseCommand = parseCommand =
@@ -330,31 +373,39 @@ parseCommand =
<|> (CmdListUnindexed <$> parseListUnindexed) <|> (CmdListUnindexed <$> parseListUnindexed)
<|> parseCat <|> parseCat
<|> parsePkgCat <|> parsePkgCat
where reg = parseRepoAdd <|> (CmdRegDel <$> parseRepoDel) <|> (parseRepoList $> CmdRegList) where
reg = parseRepoAdd <|> (CmdRegDel <$> parseRepoDel) <|> (parseRepoList $> CmdRegList)
parseCat :: Parser Command parseCat :: Parser Command
parseCat = subparser $ command "category" (info (add <|> del) $ progDesc "Manage categories") parseCat = subparser $ command "category" (info (add <|> del) $ progDesc "Manage categories")
where where
add = subparser $ command add =
"add" subparser $
( info command
( CmdCatAdd "add"
<$> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME") ( info
<*> strArgument (metavar "CATEGORY") ( CmdCatAdd
<*> optional (strOption (short 'd' <> long "description" <> metavar "DESCRIPTION")) <$> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME")
<*> optional <*> strArgument (metavar "CATEGORY")
(option Options.Applicative.auto (short 'p' <> long "priority" <> metavar "PRIORITY")) <*> 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 $
del = subparser $ command command
"rm" "rm"
( info ( info
(CmdCatDel <$> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME") <*> strArgument ( CmdCatDel <$> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME")
(metavar "CATEGORY") <*> strArgument
(metavar "CATEGORY")
)
$ progDesc "Removes category from registry"
) )
$ progDesc "Removes category from registry"
)
parsePkgCat :: Parser Command parsePkgCat :: Parser Command
parsePkgCat = subparser $ command "categorize" (info cat $ progDesc "Add or remove package from category") 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 :: Parser Command
cat = cat =
let cmd rm = if not rm then CmdPkgCatAdd else CmdPkgCatDel let cmd rm = if not rm then CmdPkgCatAdd else CmdPkgCatDel
in cmd in cmd
<$> switch (long "remove") <$> switch (long "remove")
<*> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME") <*> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME")
<*> strArgument (metavar "PACKAGE_ID") <*> strArgument (metavar "PACKAGE_ID")
<*> strArgument (metavar "CATEGORY") <*> strArgument (metavar "CATEGORY")
opts :: ParserInfo Command opts :: ParserInfo Command
opts = info (parseCommand <**> helper) (fullDesc <> progDesc "Publish tool for Embassy Packages") opts = info (parseCommand <**> helper) (fullDesc <> progDesc "Publish tool for Embassy Packages")
cliMain :: IO () cliMain :: IO ()
cliMain = execParser opts >>= \case cliMain =
CmdInit sh -> init sh execParser opts >>= \case
CmdRegAdd s pcr -> regAdd s pcr CmdInit sh -> init sh
CmdRegDel s -> regRm s CmdRegAdd s pcr -> regAdd s pcr
CmdRegList -> regLs CmdRegDel s -> regRm s
CmdUpload up -> upload up CmdRegList -> regLs
CmdIndex name pkg v shouldIndex -> if shouldIndex then index name pkg v else deindex name pkg v CmdUpload up -> upload up
CmdListUnindexed name -> listUnindexed name CmdIndex name pkg v shouldIndex -> if shouldIndex then index name pkg v else deindex name pkg v
CmdCatAdd target cat desc pri -> catAdd target cat desc pri CmdListUnindexed name -> listUnindexed name
CmdCatDel target cat -> catDel target cat CmdCatAdd target cat desc pri -> catAdd target cat desc pri
CmdPkgCatAdd target pkg cat -> pkgCatAdd target pkg cat CmdCatDel target cat -> catDel target cat
CmdPkgCatDel target pkg cat -> pkgCatDel target pkg cat CmdPkgCatAdd target pkg cat -> pkgCatAdd target pkg cat
CmdPkgCatDel target pkg cat -> pkgCatDel target pkg cat
init :: Maybe Shell -> IO () init :: Maybe Shell -> IO ()
init sh = do init sh = do
@@ -405,10 +460,9 @@ init sh = do
writeFile zshcompleter (toS res) writeFile zshcompleter (toS res)
regAdd :: String -> PublishCfgRepo -> IO () regAdd :: String -> PublishCfgRepo -> IO ()
regAdd name val = do regAdd name val = do
loc <- cfgLocation loc <- cfgLocation
PublishCfg cfg <- inputFile Dhall.auto loc PublishCfg cfg <- inputFile Dhall.auto loc
let cfg' = insert name val cfg let cfg' = insert name val cfg
writeFile loc (pretty $ embed inject $ PublishCfg cfg') writeFile loc (pretty $ embed inject $ PublishCfg cfg')
@@ -423,16 +477,18 @@ regAdd name val = do
. mappend "start9_admin:" . mappend "start9_admin:"
$ publishCfgRepoPass val $ publishCfgRepoPass val
regRm :: String -> IO () regRm :: String -> IO ()
regRm name = do regRm name = do
loc <- cfgLocation loc <- cfgLocation
PublishCfg cfg <- inputFile Dhall.auto loc PublishCfg cfg <- inputFile Dhall.auto loc
let cfg' = delete name cfg let cfg' = delete name cfg
writeFile loc (pretty $ embed inject $ PublishCfg cfg') writeFile loc (pretty $ embed inject $ PublishCfg cfg')
regLs :: IO () regLs :: IO ()
regLs = do regLs = do
loc <- cfgLocation loc <- cfgLocation
PublishCfg cfg <- inputFile Dhall.auto loc PublishCfg cfg <- inputFile Dhall.auto loc
void $ traverseWithKey f cfg void $ traverseWithKey f cfg
where where
@@ -440,19 +496,20 @@ regLs = do
putChunk $ fromString (k <> ": ") & fore yellow putChunk $ fromString (k <> ": ") & fore yellow
putChunkLn $ fromString (show $ publishCfgRepoLocation v) & fore magenta putChunkLn $ fromString (show $ publishCfgRepoLocation v) & fore magenta
upload :: Upload -> IO () upload :: Upload -> IO ()
upload (Upload name mpkg shouldIndex) = do upload (Upload name mpkg shouldIndex) = do
PublishCfgRepo {..} <- findNameInCfg name PublishCfgRepo{..} <- findNameInCfg name
pkg <- case mpkg of pkg <- case mpkg of
Nothing -> do Nothing -> do
cwd <- getCurrentDirectory cwd <- getCurrentDirectory
files <- listDirectory cwd files <- listDirectory cwd
let pkgs = filter (\n -> takeExtension n == ".s9pk") files let pkgs = filter (\n -> takeExtension n == ".s9pk") files
case pkgs of case pkgs of
[] -> do [] -> do
$logError "No package specified, and could not find one in this directory" $logError "No package specified, and could not find one in this directory"
exitWith $ ExitFailure 1 exitWith $ ExitFailure 1
[p ] -> pure (cwd </> p) [p] -> pure (cwd </> p)
(_ : _ : _) -> do (_ : _ : _) -> do
$logWarn "Ambiguous package upload request, found multiple candidates:" $logWarn "Ambiguous package upload request, found multiple candidates:"
for_ pkgs $ \f -> $logWarn (fromString f) for_ pkgs $ \f -> $logWarn (fromString f)
@@ -460,25 +517,25 @@ upload (Upload name mpkg shouldIndex) = do
Just s -> pure s Just s -> pure s
noBody <- noBody <-
parseRequest ("POST " <> show publishCfgRepoLocation <> "/admin/v0/upload") parseRequest ("POST " <> show publishCfgRepoLocation <> "/admin/v0/upload")
<&> setRequestHeaders [("accept", "text/plain")] <&> setRequestHeaders [("accept", "text/plain")]
<&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass) <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass)
size <- getFileSize pkg 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 body <- observedStreamFile (updateProgress bar . const . sfs2prog) pkg
let withBody = setRequestBody body noBody let withBody = setRequestBody body noBody
manager <- newTlsManager manager <- newTlsManager
res <- runReaderT (httpLbs withBody) manager res <- runReaderT (httpLbs withBody) manager
if getResponseStatus res == status200 if getResponseStatus res == status200
-- no output is successful then -- no output is successful
then pure () pure ()
else do else do
$logError (decodeUtf8 . LB.toStrict $ getResponseBody res) $logError (decodeUtf8 . LB.toStrict $ getResponseBody res)
exitWith $ ExitFailure 1 exitWith $ ExitFailure 1
putChunkLn $ fromString ("Successfully uploaded " <> pkg) & fore green putChunkLn $ fromString ("Successfully uploaded " <> pkg) & fore green
when shouldIndex $ do when shouldIndex $ do
home <- getHomeDirectory home <- getHomeDirectory
manifestBytes <- sourceManifest (home </> ".cargo/bin") pkg $ \c -> runConduit (c .| foldC) 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 Left s -> do
$logError $ "Could not parse the manifest of the package: " <> toS s $logError $ "Could not parse the manifest of the package: " <> toS s
exitWith $ ExitFailure 1 exitWith $ ExitFailure 1
@@ -486,45 +543,53 @@ upload (Upload name mpkg shouldIndex) = do
let pkgId = toS $ unPkgId packageManifestId let pkgId = toS $ unPkgId packageManifestId
index name pkgId packageManifestVersion index name pkgId packageManifestVersion
putChunkLn $ fromString ("Successfully indexed " <> pkgId <> "@" <> show packageManifestVersion) & fore green putChunkLn $ fromString ("Successfully indexed " <> pkgId <> "@" <> show packageManifestVersion) & fore green
where where
sfs2prog :: StreamFileStatus -> Progress () sfs2prog :: StreamFileStatus -> Progress ()
sfs2prog StreamFileStatus {..} = Progress (fromIntegral readSoFar) (fromIntegral fileSize) () sfs2prog StreamFileStatus{..} = Progress (fromIntegral readSoFar) (fromIntegral fileSize) ()
index :: String -> String -> Version -> IO () index :: String -> String -> Version -> IO ()
index name pkg v = performHttp name "POST" [i|/admin/v0/index|] (IndexPkgReq (PkgId $ toS pkg) v) index name pkg v = performHttp name "POST" [i|/admin/v0/index|] (IndexPkgReq (PkgId $ toS pkg) v)
deindex :: String -> String -> Version -> IO () deindex :: String -> String -> Version -> IO ()
deindex name pkg v = performHttp name "POST" [i|/admin/v0/deindex|] (IndexPkgReq (PkgId $ toS pkg) v) deindex name pkg v = performHttp name "POST" [i|/admin/v0/deindex|] (IndexPkgReq (PkgId $ toS pkg) v)
listUnindexed :: String -> IO () listUnindexed :: String -> IO ()
listUnindexed name = do listUnindexed name = do
PublishCfgRepo {..} <- findNameInCfg name PublishCfgRepo{..} <- findNameInCfg name
noBody <- noBody <-
parseRequest (show publishCfgRepoLocation <> "/admin/v0/deindex") parseRequest (show publishCfgRepoLocation <> "/admin/v0/deindex")
<&> setRequestHeaders [("accept", "application/json")] <&> setRequestHeaders [("accept", "application/json")]
<&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass) <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass)
PackageList {..} <- getResponseBody <$> httpJSON noBody PackageList{..} <- getResponseBody <$> httpJSON noBody
void $ flip traverseWithKey unPackageList $ \k v -> do void $
putChunk (chunk (unPkgId k <> ": ") & fore blue) flip traverseWithKey unPackageList $ \k v -> do
putChunkLn $ chunk (show v) & fore yellow putChunk (chunk (unPkgId k <> ": ") & fore blue)
putChunkLn $ chunk (show v) & fore yellow
catAdd :: String -> String -> Maybe String -> Maybe Int -> IO () catAdd :: String -> String -> Maybe String -> Maybe Int -> IO ()
catAdd target name desc pri = catAdd target name desc pri =
performHttp target "POST" [i|/admin/v0/category/#{name}|] (AddCategoryReq (toS <$> desc) pri) performHttp target "POST" [i|/admin/v0/category/#{name}|] (AddCategoryReq (toS <$> desc) pri)
catDel :: String -> String -> IO () catDel :: String -> String -> IO ()
catDel target name = performHttp target "DELETE" [i|/admin/v0/category/#{name}|] () catDel target name = performHttp target "DELETE" [i|/admin/v0/category/#{name}|] ()
pkgCatAdd :: String -> PkgId -> String -> IO () pkgCatAdd :: String -> PkgId -> String -> IO ()
pkgCatAdd target pkg cat = performHttp target "POST" [i|/admin/v0/categorize/#{cat}/#{pkg}|] () pkgCatAdd target pkg cat = performHttp target "POST" [i|/admin/v0/categorize/#{cat}/#{pkg}|] ()
pkgCatDel :: String -> PkgId -> String -> IO () pkgCatDel :: String -> PkgId -> String -> IO ()
pkgCatDel target pkg cat = performHttp target "DELETE" [i|/admin/v0/categorize/#{cat}/#{pkg}|] () pkgCatDel target pkg cat = performHttp target "DELETE" [i|/admin/v0/categorize/#{cat}/#{pkg}|] ()
findNameInCfg :: String -> IO PublishCfgRepo findNameInCfg :: String -> IO PublishCfgRepo
findNameInCfg name = do findNameInCfg name = do
loc <- cfgLocation loc <- cfgLocation
PublishCfg cfg <- inputFile Dhall.auto loc PublishCfg cfg <- inputFile Dhall.auto loc
case lookup name cfg of case lookup name cfg of
Nothing -> do Nothing -> do
@@ -532,13 +597,14 @@ findNameInCfg name = do
exitWith $ ExitFailure 1 exitWith $ ExitFailure 1
Just pcr -> pure pcr Just pcr -> pure pcr
performHttp :: ToJSON a => String -> String -> String -> a -> IO () performHttp :: ToJSON a => String -> String -> String -> a -> IO ()
performHttp target method route body = do performHttp target method route body = do
PublishCfgRepo {..} <- findNameInCfg target PublishCfgRepo{..} <- findNameInCfg target
noBody <- noBody <-
parseRequest (method <> " " <> show publishCfgRepoLocation <> route) parseRequest (method <> " " <> show publishCfgRepoLocation <> route)
<&> setRequestHeaders [("accept", "text/plain")] <&> setRequestHeaders [("accept", "text/plain")]
<&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass) <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass)
let withBody = setRequestBodyJSON body noBody let withBody = setRequestBodyJSON body noBody
res <- httpLBS withBody res <- httpLBS withBody
if getResponseStatus res == status200 if getResponseStatus res == status200
@@ -549,12 +615,13 @@ performHttp target method route body = do
instance MonadLogger IO where instance MonadLogger IO where
monadLoggerLog _ _ LevelDebug = putChunkLn . colorLog white monadLoggerLog _ _ LevelDebug = putChunkLn . colorLog white
monadLoggerLog _ _ LevelInfo = putChunkLn . colorLog blue monadLoggerLog _ _ LevelInfo = putChunkLn . colorLog blue
monadLoggerLog _ _ LevelWarn = putChunkLn . colorLog yellow monadLoggerLog _ _ LevelWarn = putChunkLn . colorLog yellow
monadLoggerLog _ _ LevelError = putChunkLn . colorLog red monadLoggerLog _ _ LevelError = putChunkLn . colorLog red
monadLoggerLog _ _ (LevelOther _) = putChunkLn . colorLog magenta monadLoggerLog _ _ (LevelOther _) = putChunkLn . colorLog magenta
colorLog :: ToLogStr msg => Radiant -> msg -> Chunk colorLog :: ToLogStr msg => Radiant -> msg -> Chunk
colorLog c m = fore c $ chunk . decodeUtf8 . fromLogStr . toLogStr $ m colorLog c m = fore c $ chunk . decodeUtf8 . fromLogStr . toLogStr $ m
instance MonadLoggerIO IO where instance MonadLoggerIO IO where

4
src/Database/Queries.hs
View File

@@ -10,8 +10,7 @@ import Database.Persist.Sql (
PersistStoreWrite (insertKey, insert_, repsert), PersistStoreWrite (insertKey, insert_, repsert),
SqlBackend, SqlBackend,
) )
import Lib.Types.AppIndex ( import Lib.Types.Core (
PackageManifest (..),
PkgId, PkgId,
) )
import Lib.Types.Emver (Version) import Lib.Types.Emver (Version)
@@ -81,6 +80,7 @@ import Database.Persist.Postgresql (
Entity (entityVal), Entity (entityVal),
runSqlPool, runSqlPool,
) )
import Lib.Types.Manifest (PackageManifest (..))
import Model ( import Model (
Category, Category,
EntityField ( EntityField (

2
src/Foundation.hs
View File

@@ -111,7 +111,7 @@ import Lib.PkgRepository (
EosRepo, EosRepo,
PkgRepo, PkgRepo,
) )
import Lib.Types.AppIndex (PkgId, S9PK) import Lib.Types.Core (PkgId, S9PK)
import Model ( import Model (
Admin (..), Admin (..),
Key (AdminKey), Key (AdminKey),

4
src/Handler/Admin.hs
View File

@@ -62,11 +62,11 @@ import Lib.PkgRepository (
getPackages, getPackages,
getVersionsFor, getVersionsFor,
) )
import Lib.Types.AppIndex ( import Lib.Types.Core (
PackageManifest (..),
PkgId (unPkgId), PkgId (unPkgId),
) )
import Lib.Types.Emver (Version (..)) import Lib.Types.Emver (Version (..))
import Lib.Types.Manifest (PackageManifest (..))
import Model ( import Model (
Category (..), Category (..),
Key (AdminKey, PkgRecordKey, VersionRecordKey), Key (AdminKey, PkgRecordKey, VersionRecordKey),

2
src/Handler/Package.hs
View File

@@ -12,7 +12,7 @@ import Handler.Package.V0.ReleaseNotes (ReleaseNotes, getReleaseNotesR)
import Handler.Package.V0.S9PK qualified import Handler.Package.V0.S9PK qualified
import Handler.Package.V0.Version (AppVersionRes, getPkgVersionR) import Handler.Package.V0.Version (AppVersionRes, getPkgVersionR)
import Handler.Types.Api (ApiVersion (..)) import Handler.Types.Api (ApiVersion (..))
import Lib.Types.AppIndex (PkgId, S9PK) import Lib.Types.Core (PkgId, S9PK)
import Yesod.Core.Types ( import Yesod.Core.Types (
JSONResponse, JSONResponse,
TypedContent, TypedContent,

2
src/Handler/Package/V0/Icon.hs
View File

@@ -14,7 +14,7 @@ import Handler.Util (
) )
import Lib.Error (S9Error (..)) import Lib.Error (S9Error (..))
import Lib.PkgRepository (getBestVersion, getIcon) import Lib.PkgRepository (getBestVersion, getIcon)
import Lib.Types.AppIndex (PkgId) import Lib.Types.Core (PkgId)
import Network.HTTP.Types (status400) import Network.HTTP.Types (status400)
import Startlude (show, ($)) import Startlude (show, ($))
import Yesod (TypedContent, addHeader, respondSource, sendChunkBS, sendResponseStatus) import Yesod (TypedContent, addHeader, respondSource, sendChunkBS, sendResponseStatus)

2
src/Handler/Package/V0/Index.hs
View File

@@ -30,7 +30,7 @@ import Handler.Types.Api (ApiVersion (..))
import Handler.Util (basicRender) import Handler.Util (basicRender)
import Lib.Error (S9Error (..)) import Lib.Error (S9Error (..))
import Lib.PkgRepository (PkgRepo, getIcon, getManifest) 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 Lib.Types.Emver (Version, VersionRange (..), parseRange, satisfies, (<||))
import Model (Category (..), Key (..), PkgDependency (..), VersionRecord (..)) import Model (Category (..), Key (..), PkgDependency (..), VersionRecord (..))
import Network.HTTP.Types (status400) import Network.HTTP.Types (status400)

2
src/Handler/Package/V0/Instructions.hs
View File

@@ -8,7 +8,7 @@ import Foundation (Handler)
import Handler.Util (getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin) import Handler.Util (getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin)
import Lib.Error (S9Error (..)) import Lib.Error (S9Error (..))
import Lib.PkgRepository (getBestVersion, getInstructions) import Lib.PkgRepository (getBestVersion, getInstructions)
import Lib.Types.AppIndex (PkgId) import Lib.Types.Core (PkgId)
import Network.HTTP.Types (status400) import Network.HTTP.Types (status400)
import Startlude (show, ($)) import Startlude (show, ($))
import Yesod (TypedContent, addHeader, respondSource, sendChunkBS, sendResponseStatus, typePlain) import Yesod (TypedContent, addHeader, respondSource, sendChunkBS, sendResponseStatus, typePlain)

2
src/Handler/Package/V0/Latest.hs
View File

@@ -8,7 +8,7 @@ import Data.List (lookup)
import Database.Queries (fetchLatestApp) import Database.Queries (fetchLatestApp)
import Foundation (Handler) import Foundation (Handler)
import Lib.Error (S9Error (..)) import Lib.Error (S9Error (..))
import Lib.Types.AppIndex (PkgId) import Lib.Types.Core (PkgId)
import Lib.Types.Emver (Version) import Lib.Types.Emver (Version)
import Model (Key (..), VersionRecord (..)) import Model (Key (..), VersionRecord (..))
import Network.HTTP.Types (status400) import Network.HTTP.Types (status400)

2
src/Handler/Package/V0/License.hs
View File

@@ -8,7 +8,7 @@ import Foundation (Handler)
import Handler.Util (getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin) import Handler.Util (getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin)
import Lib.Error (S9Error (..)) import Lib.Error (S9Error (..))
import Lib.PkgRepository (getBestVersion, getLicense) import Lib.PkgRepository (getBestVersion, getLicense)
import Lib.Types.AppIndex (PkgId) import Lib.Types.Core (PkgId)
import Network.HTTP.Types (status400) import Network.HTTP.Types (status400)
import Startlude (show, ($)) import Startlude (show, ($))
import Yesod (TypedContent, addHeader, respondSource, sendChunkBS, sendResponseStatus, typePlain) import Yesod (TypedContent, addHeader, respondSource, sendChunkBS, sendResponseStatus, typePlain)

2
src/Handler/Package/V0/Manifest.hs
View File

@@ -8,7 +8,7 @@ import Foundation (Handler)
import Handler.Util (addPackageHeader, getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin) import Handler.Util (addPackageHeader, getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin)
import Lib.Error (S9Error (..)) import Lib.Error (S9Error (..))
import Lib.PkgRepository (getBestVersion, getManifest) import Lib.PkgRepository (getBestVersion, getManifest)
import Lib.Types.AppIndex (PkgId) import Lib.Types.Core (PkgId)
import Network.HTTP.Types (status404) import Network.HTTP.Types (status404)
import Startlude (show, ($)) import Startlude (show, ($))
import Yesod (TypedContent, addHeader, respondSource, sendChunkBS, sendResponseStatus, typeJson) import Yesod (TypedContent, addHeader, respondSource, sendChunkBS, sendResponseStatus, typeJson)

2
src/Handler/Package/V0/ReleaseNotes.hs
View File

@@ -7,7 +7,7 @@ import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HM import Data.HashMap.Strict qualified as HM
import Database.Queries (fetchAllAppVersions) import Database.Queries (fetchAllAppVersions)
import Foundation (Handler, RegistryCtx (..)) import Foundation (Handler, RegistryCtx (..))
import Lib.Types.AppIndex (PkgId) import Lib.Types.Core (PkgId)
import Lib.Types.Emver (Version) import Lib.Types.Emver (Version)
import Model (VersionRecord (..)) import Model (VersionRecord (..))
import Startlude (Down (..), Eq, Show, Text, fst, pure, sortOn, ($), (&&&), (.), (<$>)) import Startlude (Down (..), Eq, Show, Text, fst, pure, sortOn, ($), (&&&), (.), (<$>))

2
src/Handler/Package/V0/S9PK.hs
View File

@@ -12,7 +12,7 @@ import GHC.Show (show)
import Handler.Util (addPackageHeader, getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin) import Handler.Util (addPackageHeader, getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin)
import Lib.Error (S9Error (..)) import Lib.Error (S9Error (..))
import Lib.PkgRepository (getBestVersion, getPackage) import Lib.PkgRepository (getBestVersion, getPackage)
import Lib.Types.AppIndex (PkgId (..), S9PK) import Lib.Types.Core (PkgId (..), S9PK)
import Lib.Types.Emver (Version (..)) import Lib.Types.Emver (Version (..))
import Network.HTTP.Types (status404) import Network.HTTP.Types (status404)
import Startlude (Maybe (..), pure, void, ($), (.), (>>=)) import Startlude (Maybe (..), pure, void, ($), (.), (>>=))

2
src/Handler/Package/V0/Version.hs
View File

@@ -12,7 +12,7 @@ import Handler.Util (
) )
import Lib.Error (S9Error (..)) import Lib.Error (S9Error (..))
import Lib.PkgRepository (getBestVersion) import Lib.PkgRepository (getBestVersion)
import Lib.Types.AppIndex (PkgId) import Lib.Types.Core (PkgId)
import Lib.Types.Emver (Version (..)) import Lib.Types.Emver (Version (..))
import Network.HTTP.Types (status404) import Network.HTTP.Types (status404)
import Startlude (Eq, Maybe, Show, (.), (<$>)) import Startlude (Eq, Maybe, Show, (.), (<$>))

2
src/Handler/Util.hs
View File

@@ -12,7 +12,7 @@ import Data.Text qualified as T
import Data.Text.Lazy qualified as TL import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.Builder qualified as TB import Data.Text.Lazy.Builder qualified as TB
import Lib.PkgRepository (PkgRepo, getHash) import Lib.PkgRepository (PkgRepo, getHash)
import Lib.Types.AppIndex (PkgId) import Lib.Types.Core (PkgId)
import Lib.Types.Emver ( import Lib.Types.Emver (
Version, Version,
VersionRange, VersionRange,

473
src/Lib/PkgRepository.hs
View File

@@ -1,180 +1,199 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# LANGUAGE GADTs #-}
module Lib.PkgRepository where module Lib.PkgRepository where
import Conduit ( (.|) import Conduit (
, ConduitT ConduitT,
, MonadResource MonadResource,
, runConduit runConduit,
, runResourceT runResourceT,
, sinkFileCautious sinkFileCautious,
, sourceFile sourceFile,
) (.|),
import Control.Monad.Logger ( MonadLogger )
, MonadLoggerIO import Control.Monad.Logger (
, logError MonadLogger,
, logInfo MonadLoggerIO,
, logWarn logError,
) logInfo,
import Control.Monad.Reader.Has ( Has logWarn,
, ask )
, asks import Control.Monad.Reader.Has (
) Has,
import Crypto.Hash ( SHA256 ) ask,
import Crypto.Hash.Conduit ( hashFile ) asks,
import Data.Aeson ( eitherDecodeFileStrict' ) )
import qualified Data.Attoparsec.Text as Atto import Crypto.Hash (SHA256)
import Data.Attoparsec.Text ( parseOnly ) import Crypto.Hash.Conduit (hashFile)
import Data.ByteArray.Encoding ( Base(Base16) import Data.Aeson (eitherDecodeFileStrict')
, convertToBase import Data.Attoparsec.Text (parseOnly)
) import Data.Attoparsec.Text qualified as Atto
import Data.ByteString ( readFile import Data.ByteArray.Encoding (
, writeFile Base (Base16),
) convertToBase,
import qualified Data.HashMap.Strict as HM )
import Data.String.Interpolate.IsString import Data.ByteString (
( i ) readFile,
import qualified Data.Text as T writeFile,
import Data.Time ( getCurrentTime ) )
import Database.Esqueleto.Experimental import Data.HashMap.Strict qualified as HM
( ConnectionPool import Data.String.Interpolate.IsString (
, insertUnique i,
, runSqlPool )
) import Data.Text qualified as T
import Database.Persist ( (=.) import Data.Time (getCurrentTime)
, insertKey import Database.Esqueleto.Experimental (
, update ConnectionPool,
, upsert insertUnique,
) runSqlPool,
import Database.Persist.Sql ( SqlPersistT )
, runSqlPoolNoTransaction import Database.Persist (
) insertKey,
import Database.PostgreSQL.Simple ( SqlError(sqlState) ) update,
import Lib.Error ( S9Error(NotFoundE) ) upsert,
import qualified Lib.External.AppMgr as AppMgr (=.),
import Lib.Types.AppIndex ( PackageDependency(..) )
, PackageManifest(..) import Database.Persist.Sql (
, PkgId(..) SqlPersistT,
, packageDependencyVersion runSqlPoolNoTransaction,
, packageManifestDependencies )
) import Database.PostgreSQL.Simple (SqlError (sqlState))
import Lib.Types.Emver ( Version import Lib.Error (S9Error (NotFoundE))
, VersionRange import Lib.External.AppMgr qualified as AppMgr
, parseVersion import Lib.Types.Core (
, satisfies PkgId (..),
) )
import Model ( EntityField(EosHashHash, PkgRecordUpdatedAt) import Lib.Types.Emver (
, EosHash(EosHash) Version,
, Key(PkgRecordKey) VersionRange,
, PkgDependency(PkgDependency) parseVersion,
, PkgRecord(PkgRecord) satisfies,
) )
import Startlude ( ($) import Lib.Types.Manifest (PackageDependency (..), PackageManifest (..))
, (&&) import Model (
, (.) EntityField (EosHashHash, PkgRecordUpdatedAt),
, (/=) EosHash (EosHash),
, (<$>) Key (PkgRecordKey),
, Bool(..) PkgDependency (PkgDependency),
, ByteString PkgRecord (PkgRecord),
, Down(..) )
, Either(..) import Startlude (
, Eq((==)) Bool (..),
, Exception ByteString,
, FilePath Down (..),
, IO Either (..),
, Integer Eq ((==)),
, Maybe(..) Exception,
, MonadIO(liftIO) FilePath,
, MonadReader IO,
, Ord(compare) Integer,
, Show Maybe (..),
, SomeException(..) MonadIO (liftIO),
, decodeUtf8 MonadReader,
, filter Ord (compare),
, find Show,
, first SomeException (..),
, flip decodeUtf8,
, for_ filter,
, fst find,
, headMay first,
, not flip,
, on for_,
, partitionEithers fst,
, pure headMay,
, show not,
, snd on,
, sortBy partitionEithers,
, throwIO pure,
, toS show,
, void snd,
) sortBy,
import System.FSNotify ( ActionPredicate throwIO,
, Event(..) toS,
, eventPath void,
, watchTree ($),
, withManager (&&),
) (.),
import System.FilePath ( (<.>) (/=),
, (</>) (<$>),
, takeBaseName )
, takeDirectory import System.FSNotify (
, takeExtension ActionPredicate,
, takeFileName Event (..),
) eventPath,
import UnliftIO ( MonadUnliftIO watchTree,
, askRunInIO withManager,
, async )
, catch import System.FilePath (
, mapConcurrently_ takeBaseName,
, newEmptyMVar takeDirectory,
, takeMVar takeExtension,
, tryPutMVar takeFileName,
, wait (<.>),
) (</>),
import UnliftIO.Concurrent ( forkIO ) )
import UnliftIO.Directory ( doesDirectoryExist import UnliftIO (
, doesPathExist MonadUnliftIO,
, getFileSize askRunInIO,
, listDirectory async,
, removeFile catch,
, renameFile mapConcurrently_,
) newEmptyMVar,
import UnliftIO.Exception ( handle ) takeMVar,
import Yesod.Core.Content ( typeGif tryPutMVar,
, typeJpeg wait,
, typePlain )
, typePng import UnliftIO.Concurrent (forkIO)
, typeSvg import UnliftIO.Directory (
) doesDirectoryExist,
import Yesod.Core.Types ( ContentType ) 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 newtype ManifestParseException = ManifestParseException FilePath
deriving Show deriving (Show)
instance Exception ManifestParseException instance Exception ManifestParseException
data PkgRepo = PkgRepo data PkgRepo = PkgRepo
{ pkgRepoFileRoot :: !FilePath { pkgRepoFileRoot :: !FilePath
, pkgRepoAppMgrBin :: !FilePath , pkgRepoAppMgrBin :: !FilePath
} }
newtype EosRepo = EosRepo newtype EosRepo = EosRepo
{ eosRepoFileRoot :: FilePath { eosRepoFileRoot :: FilePath
} }
getPackages :: (MonadIO m, MonadReader r m, Has PkgRepo r) => m [PkgId] getPackages :: (MonadIO m, MonadReader r m, Has PkgRepo r) => m [PkgId]
getPackages = do getPackages = do
root <- asks pkgRepoFileRoot root <- asks pkgRepoFileRoot
paths <- listDirectory root paths <- listDirectory root
pure $ PkgId . toS <$> paths pure $ PkgId . toS <$> paths
getVersionsFor :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) => PkgId -> m [Version] getVersionsFor :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) => PkgId -> m [Version]
getVersionsFor pkg = do getVersionsFor pkg = do
root <- asks pkgRepoFileRoot root <- asks pkgRepoFileRoot
@@ -188,52 +207,66 @@ getVersionsFor pkg = do
pure successes pure successes
else pure [] else pure []
getViableVersions :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) => PkgId -> VersionRange -> m [Version] getViableVersions :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) => PkgId -> VersionRange -> m [Version]
getViableVersions pkg spec = filter (`satisfies` spec) <$> getVersionsFor pkg getViableVersions pkg spec = filter (`satisfies` spec) <$> getVersionsFor pkg
getBestVersion :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m)
=> PkgId getBestVersion ::
-> VersionRange (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) =>
-> Bool PkgId ->
-> m (Maybe Version) VersionRange ->
Bool ->
m (Maybe Version)
getBestVersion pkg spec preferMin = headMay . sortBy comparator <$> getViableVersions pkg spec 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 :: MonadUnliftIO m => ConnectionPool -> PackageManifest -> m ()
loadPkgDependencies appConnPool manifest = do loadPkgDependencies appConnPool manifest = do
let pkgId = packageManifestId manifest let pkgId = packageManifestId manifest
let pkgVersion = packageManifestVersion manifest let pkgVersion = packageManifestVersion manifest
let deps = packageManifestDependencies manifest let deps = packageManifestDependencies manifest
time <- liftIO getCurrentTime time <- liftIO getCurrentTime
_ <- runWith appConnPool $ insertKey (PkgRecordKey pkgId) (PkgRecord time Nothing) `catch` \(e :: SqlError) -> _ <-
-- 23505 is "already exists" runWith appConnPool $
if sqlState e == "23505" then update (PkgRecordKey pkgId) [PkgRecordUpdatedAt =. Just time] else throwIO e 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 let deps' = first PkgRecordKey <$> HM.toList deps
for_ for_
deps' deps'
(\d -> flip runSqlPool appConnPool $ do ( \d -> flip runSqlPool appConnPool $ do
_ <- runWith appConnPool $ insertKey (fst d) (PkgRecord time Nothing) `catch` \(e :: SqlError) -> _ <-
-- 23505 is "already exists" runWith appConnPool $
if sqlState e == "23505" then update (fst d) [PkgRecordUpdatedAt =. Just time] else throwIO e insertKey (fst d) (PkgRecord time Nothing) `catch` \(e :: SqlError) ->
insertUnique -- 23505 is "already exists"
$ PkgDependency time (PkgRecordKey pkgId) pkgVersion (fst d) (packageDependencyVersion . snd $ d) 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 where
runWith :: MonadUnliftIO m => ConnectionPool -> SqlPersistT m a -> m a runWith :: MonadUnliftIO m => ConnectionPool -> SqlPersistT m a -> m a
runWith pool action = runSqlPoolNoTransaction action pool Nothing runWith pool action = runSqlPoolNoTransaction action pool Nothing
-- extract all package assets into their own respective files -- extract all package assets into their own respective files
extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => ConnectionPool -> FilePath -> m () extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => ConnectionPool -> FilePath -> m ()
extractPkg pool fp = handle @_ @SomeException cleanup $ do extractPkg pool fp = handle @_ @SomeException cleanup $ do
$logInfo [i|Extracting package: #{fp}|] $logInfo [i|Extracting package: #{fp}|]
PkgRepo { pkgRepoAppMgrBin = appmgr } <- ask PkgRepo{pkgRepoAppMgrBin = appmgr} <- ask
let pkgRoot = takeDirectory fp let pkgRoot = takeDirectory fp
manifestTask <- async $ runResourceT $ AppMgr.sourceManifest appmgr fp $ sinkIt (pkgRoot </> "manifest.json") manifestTask <- async $ runResourceT $ AppMgr.sourceManifest appmgr fp $ sinkIt (pkgRoot </> "manifest.json")
pkgHashTask <- async $ AppMgr.getPackageHash appmgr fp pkgHashTask <- async $ AppMgr.getPackageHash appmgr fp
instructionsTask <- async $ runResourceT $ AppMgr.sourceInstructions appmgr fp $ sinkIt instructionsTask <-
(pkgRoot </> "instructions.md") async $
runResourceT $
AppMgr.sourceInstructions appmgr fp $
sinkIt
(pkgRoot </> "instructions.md")
licenseTask <- async $ runResourceT $ AppMgr.sourceLicense appmgr fp $ sinkIt (pkgRoot </> "license.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 wait manifestTask
eManifest <- liftIO (eitherDecodeFileStrict' (pkgRoot </> "manifest.json")) eManifest <- liftIO (eitherDecodeFileStrict' (pkgRoot </> "manifest.json"))
case eManifest of case eManifest of
@@ -242,11 +275,12 @@ extractPkg pool fp = handle @_ @SomeException cleanup $ do
liftIO . throwIO $ ManifestParseException (pkgRoot </> "manifest.json") liftIO . throwIO $ ManifestParseException (pkgRoot </> "manifest.json")
Right manifest -> do Right manifest -> do
wait iconTask wait iconTask
let iconDest = "icon" <.> case packageManifestIcon manifest of let iconDest =
Nothing -> "png" "icon" <.> case packageManifestIcon manifest of
Just x -> case takeExtension (T.unpack x) of Nothing -> "png"
"" -> "png" Just x -> case takeExtension (T.unpack x) of
other -> other "" -> "png"
other -> other
loadPkgDependencies pool manifest loadPkgDependencies pool manifest
liftIO $ renameFile (pkgRoot </> "icon.tmp") (pkgRoot </> iconDest) liftIO $ renameFile (pkgRoot </> "icon.tmp") (pkgRoot </> iconDest)
hash <- wait pkgHashTask hash <- wait pkgHashTask
@@ -263,97 +297,112 @@ extractPkg pool fp = handle @_ @SomeException cleanup $ do
mapConcurrently_ (removeFile . (pkgRoot </>)) toRemove mapConcurrently_ (removeFile . (pkgRoot </>)) toRemove
throwIO e throwIO e
watchEosRepoRoot :: (MonadUnliftIO m, MonadReader r m, Has EosRepo r, MonadLoggerIO m) => ConnectionPool -> m (IO Bool) watchEosRepoRoot :: (MonadUnliftIO m, MonadReader r m, Has EosRepo r, MonadLoggerIO m) => ConnectionPool -> m (IO Bool)
watchEosRepoRoot pool = do watchEosRepoRoot pool = do
$logInfo "Starting FSNotify Watch Manager: EOS" $logInfo "Starting FSNotify Watch Manager: EOS"
root <- asks eosRepoFileRoot root <- asks eosRepoFileRoot
runInIO <- askRunInIO runInIO <- askRunInIO
box <- newEmptyMVar @_ @() box <- newEmptyMVar @_ @()
_ <- forkIO $ liftIO $ withManager $ \watchManager -> do _ <- forkIO $
stop <- watchTree watchManager root shouldIndex $ \evt -> do liftIO $
let os = eventPath evt withManager $ \watchManager -> do
void . forkIO $ runInIO $ do stop <- watchTree watchManager root shouldIndex $ \evt -> do
indexOs pool os let os = eventPath evt
takeMVar box void . forkIO $
stop runInIO $ do
indexOs pool os
takeMVar box
stop
pure $ tryPutMVar box () pure $ tryPutMVar box ()
where where
shouldIndex :: ActionPredicate 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 (Modified path _ isDir) = not isDir && takeExtension path == ".img"
shouldIndex _ = False shouldIndex _ = False
indexOs :: (MonadUnliftIO m, MonadLoggerIO m) => ConnectionPool -> FilePath -> m () indexOs :: (MonadUnliftIO m, MonadLoggerIO m) => ConnectionPool -> FilePath -> m ()
indexOs pool path = do indexOs pool path = do
hash <- hashFile @_ @SHA256 path hash <- hashFile @_ @SHA256 path
let hashText = decodeUtf8 $ convertToBase Base16 hash let hashText = decodeUtf8 $ convertToBase Base16 hash
let vText = takeFileName (takeDirectory path) let vText = takeFileName (takeDirectory path)
let eVersion = parseOnly parseVersion . T.pack $ vText let eVersion = parseOnly parseVersion . T.pack $ vText
case eVersion of case eVersion of
Left e -> $logError [i|Invalid Version Number (#{vText}): #{e}|] Left e -> $logError [i|Invalid Version Number (#{vText}): #{e}|]
Right version -> Right version ->
void $ flip runSqlPool pool $ upsert (EosHash version hashText) [EosHashHash =. hashText] void $ flip runSqlPool pool $ upsert (EosHash version hashText) [EosHashHash =. hashText]
getManifestLocation :: (MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m FilePath getManifestLocation :: (MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m FilePath
getManifestLocation pkg version = do getManifestLocation pkg version = do
root <- asks pkgRepoFileRoot root <- asks pkgRepoFileRoot
pure $ root </> show pkg </> show version </> "manifest.json" pure $ root </> show pkg </> show version </> "manifest.json"
getManifest :: (MonadResource m, MonadReader r m, Has PkgRepo r)
=> PkgId getManifest ::
-> Version (MonadResource m, MonadReader r m, Has PkgRepo r) =>
-> m (Integer, ConduitT () ByteString m ()) PkgId ->
Version ->
m (Integer, ConduitT () ByteString m ())
getManifest pkg version = do getManifest pkg version = do
manifestPath <- getManifestLocation pkg version manifestPath <- getManifestLocation pkg version
n <- getFileSize manifestPath n <- getFileSize manifestPath
pure (n, sourceFile manifestPath) pure (n, sourceFile manifestPath)
getInstructions :: (MonadResource m, MonadReader r m, Has PkgRepo r)
=> PkgId getInstructions ::
-> Version (MonadResource m, MonadReader r m, Has PkgRepo r) =>
-> m (Integer, ConduitT () ByteString m ()) PkgId ->
Version ->
m (Integer, ConduitT () ByteString m ())
getInstructions pkg version = do getInstructions pkg version = do
root <- asks pkgRepoFileRoot root <- asks pkgRepoFileRoot
let instructionsPath = root </> show pkg </> show version </> "instructions.md" let instructionsPath = root </> show pkg </> show version </> "instructions.md"
n <- getFileSize instructionsPath n <- getFileSize instructionsPath
pure (n, sourceFile instructionsPath) pure (n, sourceFile instructionsPath)
getLicense :: (MonadResource m, MonadReader r m, Has PkgRepo r)
=> PkgId getLicense ::
-> Version (MonadResource m, MonadReader r m, Has PkgRepo r) =>
-> m (Integer, ConduitT () ByteString m ()) PkgId ->
Version ->
m (Integer, ConduitT () ByteString m ())
getLicense pkg version = do getLicense pkg version = do
root <- asks pkgRepoFileRoot root <- asks pkgRepoFileRoot
let licensePath = root </> show pkg </> show version </> "license.md" let licensePath = root </> show pkg </> show version </> "license.md"
n <- getFileSize licensePath n <- getFileSize licensePath
pure (n, sourceFile licensePath) pure (n, sourceFile licensePath)
getIcon :: (MonadResource m, MonadReader r m, Has PkgRepo r)
=> PkgId getIcon ::
-> Version (MonadResource m, MonadReader r m, Has PkgRepo r) =>
-> m (ContentType, Integer, ConduitT () ByteString m ()) PkgId ->
Version ->
m (ContentType, Integer, ConduitT () ByteString m ())
getIcon pkg version = do getIcon pkg version = do
root <- asks pkgRepoFileRoot root <- asks pkgRepoFileRoot
let pkgRoot = root </> show pkg </> show version let pkgRoot = root </> show pkg </> show version
mIconFile <- find ((== "icon") . takeBaseName) <$> listDirectory pkgRoot mIconFile <- find ((== "icon") . takeBaseName) <$> listDirectory pkgRoot
case mIconFile of case mIconFile of
Nothing -> throwIO $ NotFoundE [i|#{pkg}: Icon|] Nothing -> throwIO $ NotFoundE [i|#{pkg}: Icon|]
Just x -> do Just x -> do
let ct = case takeExtension x of let ct = case takeExtension x of
".png" -> typePng ".png" -> typePng
".jpg" -> typeJpeg ".jpg" -> typeJpeg
".jpeg" -> typeJpeg ".jpeg" -> typeJpeg
".svg" -> typeSvg ".svg" -> typeSvg
".gif" -> typeGif ".gif" -> typeGif
_ -> typePlain _ -> typePlain
n <- getFileSize (pkgRoot </> x) n <- getFileSize (pkgRoot </> x)
pure (ct, n, sourceFile (pkgRoot </> x)) pure (ct, n, sourceFile (pkgRoot </> x))
getHash :: (MonadIO m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m ByteString getHash :: (MonadIO m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m ByteString
getHash pkg version = do getHash pkg version = do
root <- asks pkgRepoFileRoot root <- asks pkgRepoFileRoot
let hashPath = root </> show pkg </> show version </> "hash.bin" let hashPath = root </> show pkg </> show version </> "hash.bin"
liftIO $ readFile hashPath liftIO $ readFile hashPath
getPackage :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m (Maybe FilePath) getPackage :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m (Maybe FilePath)
getPackage pkg version = do getPackage pkg version = do
root <- asks pkgRepoFileRoot root <- asks pkgRepoFileRoot

108
src/Lib/Types/Core.hs Normal file
View File

@@ -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

147
src/Lib/Types/AppIndex.hs → src/Lib/Types/Manifest.hs
View File

@@ -1,108 +1,20 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
module Lib.Types.AppIndex where module Lib.Types.Manifest where
import Startlude import Control.Monad.Fail (MonadFail (..))
import Data.Aeson (FromJSON (..), withObject, (.:), (.:?))
-- NOTE: leave eitherDecode for inline test evaluation below import Data.HashMap.Internal.Strict (HashMap)
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 Data.HashMap.Strict qualified as HM import Data.HashMap.Strict qualified as HM
import Data.String.Interpolate.IsString ( import Data.String.Interpolate.IsString (i)
i,
)
import Data.Text qualified as T import Data.Text qualified as T
import Database.Persist ( import Lib.Types.Core (PkgId)
PersistField (..), import Lib.Types.Emver (Version (..), VersionRange)
PersistValue (PersistText), import Startlude (ByteString, Eq, Generic, Hashable, Maybe (..), Monad ((>>=)), Read, Show, Text, for, pure, readMaybe, ($))
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 (..))
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 data PackageManifest = PackageManifest
{ packageManifestId :: !PkgId { packageManifestId :: !PkgId
, packageManifestTitle :: !Text , packageManifestTitle :: !Text
@@ -111,8 +23,8 @@ data PackageManifest = PackageManifest
, packageManifestDescriptionShort :: !Text , packageManifestDescriptionShort :: !Text
, packageManifestReleaseNotes :: !Text , packageManifestReleaseNotes :: !Text
, packageManifestIcon :: !(Maybe Text) , packageManifestIcon :: !(Maybe Text)
, packageManifestAlerts :: !(HM.HashMap ServiceAlert (Maybe Text)) , packageManifestAlerts :: !(HashMap ServiceAlert (Maybe Text))
, packageManifestDependencies :: !(HM.HashMap PkgId PackageDependency) , packageManifestDependencies :: !(HashMap PkgId PackageDependency)
, packageManifestEosVersion :: !Version , packageManifestEosVersion :: !Version
} }
deriving (Show) deriving (Show)
@@ -138,33 +50,26 @@ instance FromJSON PackageManifest where
pure PackageManifest{..} pure PackageManifest{..}
newtype Extension (a :: Symbol) = Extension String deriving (Eq) data PackageDependency = PackageDependency
type S9PK = Extension "s9pk" { 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 data ServiceAlert = INSTALL | UNINSTALL | RESTORE | START | STOP
extension = symbolVal deriving (Show, Eq, Generic, Hashable, Read)
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
-- >>> eitherDecode testManifest :: Either String PackageManifest -- >>> eitherDecode testManifest :: Either String PackageManifest
testManifest :: BS.ByteString testManifest :: ByteString
testManifest = testManifest =
[i|{ [i|{
"id": "embassy-pages", "id": "embassy-pages",
@@ -303,4 +208,4 @@ testManifest =
"config": null "config": null
} }
} }
}|] }|]

71
src/Model.hs
View File

@@ -1,40 +1,47 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
module Model where module Model where
import Crypto.Hash ( Digest import Crypto.Hash (
, SHA256 Digest,
) SHA256,
import Database.Persist.TH ( mkMigrate )
, mkPersist import Database.Persist.TH (
, persistLowerCase mkMigrate,
, share mkPersist,
, sqlSettings persistLowerCase,
) share,
import Lib.Types.AppIndex ( PkgId(PkgId) ) sqlSettings,
import Lib.Types.Emver ( Version )
, VersionRange import Lib.Types.Core (PkgId (PkgId))
) import Lib.Types.Emver (
import Orphans.Cryptonite ( ) Version,
import Orphans.Emver ( ) VersionRange,
import Startlude ( Eq )
, Int import Orphans.Cryptonite ()
, Show import Orphans.Emver ()
, Text import Startlude (
, UTCTime Eq,
, Word32 Int,
) Show,
Text,
UTCTime,
Word32,
)
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
share
[mkPersist sqlSettings, mkMigrate "migrateAll"]
[persistLowerCase|
PkgRecord PkgRecord
Id PkgId sql=pkg_id Id PkgId sql=pkg_id
createdAt UTCTime createdAt UTCTime