Start9/registry
2
0
Fork 0
mirror of https://github.com/Start9Labs/registry.git synced 2026-03-26 10:21:51 +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 #-}
{-# 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

4
src/Database/Queries.hs
View File

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

2
src/Foundation.hs
View File

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

4
src/Handler/Admin.hs
View File

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

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.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,

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

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

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

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

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

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

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

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

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

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

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

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

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 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, ($), (&&&), (.), (<$>))

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 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, ($), (.), (>>=))

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

@@ -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, (.), (<$>))

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.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,

473
src/Lib/PkgRepository.hs
View File

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

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 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
}
}
}|]
}|]

71
src/Model.hs
View File

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