diff --git a/config/routes b/config/routes index 02a73db..fed18af 100644 --- a/config/routes +++ b/config/routes @@ -2,10 +2,10 @@ / AppsManifestR GET --get current apps listing /version VersionR GET --- /version/:appId VersionAppR GET --get most recent appId version --- /sys/version/agent VersionAgentR GET --get most recent agent version --- /sys/version/appmgr VersionAppMgrR GET --get most recent appmgr version +/version/#Text VersionAppR GET --get most recent appId version +/sys/version/agent VersionAgentR GET --get most recent agent version +/sys/version/appmgr VersionAppMgrR GET --get most recent appmgr version --- /{:appId}.s9pk AppR GET --get most recent appId at appversion spec, defaults to >=0.0.0 -- ?version={semver-spec} --- /sys/agent.s9pk AgentR GET --get most recent agent at appversion -- ?version={semver-spec} --- /sys/appmgr.s9pk AppMgrR GET --get most recent appmgr at appversion -- ?version={semver-spec} \ No newline at end of file +/sys/agent.s9pk AgentR GET --get most recent agent at appversion -- ?spec={semver-spec} +/sys/appmgr.s9pk AppMgrR GET --get most recent appmgr at appversion -- ?spec={semver-spec} +!/#S9PK AppR GET --get most recent appId at appversion spec, defaults to >=0.0.0 -- ?spec={semver-spec} \ No newline at end of file diff --git a/package.yaml b/package.yaml index 08797b7..74b5256 100644 --- a/package.yaml +++ b/package.yaml @@ -71,6 +71,7 @@ dependencies: - protolude - safe - secp256k1-haskell +- split - template-haskell - text >=0.11 && <2.0 - time diff --git a/resources/apps.yaml b/resources/apps/apps.yaml similarity index 100% rename from resources/apps.yaml rename to resources/apps/apps.yaml diff --git a/resources/bitcoind/0.18.1/version.yaml b/resources/bitcoind/0.18.1/version.yaml deleted file mode 100644 index 610cb0a..0000000 --- a/resources/bitcoind/0.18.1/version.yaml +++ /dev/null @@ -1,2 +0,0 @@ -version: 0.18.1 -release-notes: "Some stuff" \ No newline at end of file diff --git a/resources/bitcoind/app.yaml b/resources/bitcoind/app.yaml deleted file mode 100644 index 27b96af..0000000 --- a/resources/bitcoind/app.yaml +++ /dev/null @@ -1,5 +0,0 @@ -title: "Bitcoin Core" -description: - short: "A Bitcoin Full Node" - long: "The bitcoin full node implementation by Bitcoin Core." -icon-type: png \ No newline at end of file diff --git a/resources/sys/appmgr/0.0.0/appmgr.s9pk b/resources/sys/appmgr/0.0.0/appmgr.s9pk new file mode 100644 index 0000000..158db5b --- /dev/null +++ b/resources/sys/appmgr/0.0.0/appmgr.s9pk @@ -0,0 +1 @@ +some appmgr code \ No newline at end of file diff --git a/src/Application.hs b/src/Application.hs index 56dc089..0f92fa4 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -51,7 +51,7 @@ import Yesod.Persist.Core -- Don't forget to add new modules to your cabal file! import Foundation import Handler.Apps -import Handler.Status +import Handler.Version import Lib.Ssl import Model import Settings diff --git a/src/Foundation.hs b/src/Foundation.hs index a1f762f..c350c95 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -11,7 +11,7 @@ import Startlude import Control.Monad.Logger (LogSource) import Data.IORef import Database.Persist.Sql -import Lib.Types.Semver +import Lib.Registry import Yesod.Core import Yesod.Core.Types (Logger) import qualified Yesod.Core.Unsafe as Unsafe diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index 3b7c18c..373dfd2 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -12,11 +12,14 @@ import Data.Aeson import qualified Data.ByteString.Lazy as BS import Data.Conduit import qualified Data.Conduit.Binary as CB -import System.FilePath +import System.Directory import Yesod.Core import Foundation -import Lib.Resource +import Handler.Types.Status +import Lib.Registry +import Lib.Semver +import Lib.Types.Semver pureLog :: Show a => a -> Handler a pureLog = liftA2 (*>) ($logInfo . show) pure @@ -24,6 +27,28 @@ pureLog = liftA2 (*>) ($logInfo . show) pure logRet :: ToJSON a => Handler a -> Handler a logRet = (>>= liftA2 (*>) ($logInfo . decodeUtf8 . BS.toStrict . encode) pure) -type AppManifestYml = TypedContent -getAppsManifestR :: Handler AppManifestYml -getAppsManifestR = respondSource typePlain $ CB.sourceFile manifestPath .| awaitForever sendChunkBS +getAppsManifestR :: Handler TypedContent +getAppsManifestR = respondSource typePlain $ CB.sourceFile appManifestPath .| awaitForever sendChunkBS + +getAgentR :: Handler TypedContent +getAgentR = getApp sysResourceDir $ S9PK "agent" + +getAppMgrR :: Handler TypedContent +getAppMgrR = getApp sysResourceDir $ S9PK "appmgr" + +getAppR :: S9PK -> Handler TypedContent +getAppR = getApp appResourceDir + +getApp :: FilePath -> S9PK -> Handler TypedContent +getApp rootDir (S9PK appId) = do + spec <- querySpecD mostRecentVersion <$> lookupGetParam "spec" + appVersions <- registeredAppVersions appId <$> loadRegistry rootDir + case getSpecifiedAppVersion spec appVersions of + Nothing -> respondSource typePlain sendFlush + Just (RegisteredAppVersion (_, filePath)) -> do + exists <- liftIO $ doesFileExist filePath + if exists + then respondSource typePlain $ CB.sourceFile filePath .| awaitForever sendChunkBS + else respondSource typePlain sendFlush + + diff --git a/src/Handler/Status.hs b/src/Handler/Status.hs deleted file mode 100644 index 3b828c9..0000000 --- a/src/Handler/Status.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Handler.Status where - -import Startlude - -import Constants -import Foundation -import Handler.Types.Status -import Lib.Types.Semver - -getVersionR :: Handler AppVersionRes -getVersionR = pure . AppVersionRes $ registryVersion diff --git a/src/Handler/Types/Apps.hs b/src/Handler/Types/Apps.hs deleted file mode 100644 index c5f3dcb..0000000 --- a/src/Handler/Types/Apps.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -module Handler.Types.Apps where - -import Startlude - -import Data.Aeson -import Yesod.Core.Content - -import Lib.Types.StoreApp - -newtype AvailableAppsRes = AvailableAppsRes - { availableApps :: [StoreApp] - } deriving (Eq, Show) -instance ToJSON AvailableAppsRes where - toJSON = toJSON . availableApps -instance ToTypedContent AvailableAppsRes where - toTypedContent = toTypedContent . toJSON -instance ToContent AvailableAppsRes where - toContent = toContent . toJSON diff --git a/src/Handler/Types/Register.hs b/src/Handler/Types/Register.hs deleted file mode 100644 index 093a814..0000000 --- a/src/Handler/Types/Register.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE RecordWildCards #-} -module Handler.Types.Register where - -import Startlude - -import Control.Monad.Fail -import Data.Aeson -import Data.ByteArray.Encoding -import Data.ByteArray.Sized - -data RegisterReq = RegisterReq - { registerProductKey :: Text - , registerPubKey :: SizedByteArray 33 ByteString - } deriving (Eq, Show) -instance FromJSON RegisterReq where - parseJSON = withObject "Register Request" $ \o -> do - registerProductKey <- o .: "productKey" - registerPubKey <- o .: "pubKey" >>= \t -> - case sizedByteArray <=< hush . convertFromBase Base16 $ encodeUtf8 t of - Nothing -> fail "Invalid Hex Encoded Public Key" - Just x -> pure x - pure RegisterReq{..} diff --git a/src/Handler/Types/Status.hs b/src/Handler/Types/Status.hs index 2f3c2bf..85ec323 100644 --- a/src/Handler/Types/Status.hs +++ b/src/Handler/Types/Status.hs @@ -1,20 +1,31 @@ -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} module Handler.Types.Status where import Startlude import Data.Aeson -import Data.Text import Yesod.Core.Content import Lib.Types.Semver -import Lib.Types.StoreApp -newtype AppVersionRes = AppVersionRes - { unAppVersionRes :: AppVersion } deriving (Eq, Show) +newtype AppVersionRes = AppVersionRes { unAppVersionRes ::AppVersion } deriving (Eq, Show) instance ToJSON AppVersionRes where - toJSON AppVersionRes{unAppVersionRes} = object ["version" .= unAppVersionRes] + toJSON AppVersionRes{ unAppVersionRes } = object ["version" .= unAppVersionRes] + instance ToContent AppVersionRes where toContent = toContent . toJSON instance ToTypedContent AppVersionRes where toTypedContent = toTypedContent . toJSON + +-- Ugh +instance ToContent (Maybe AppVersionRes) where + toContent = toContent . toJSON +instance ToTypedContent (Maybe AppVersionRes) where + toTypedContent = toTypedContent . toJSON + +querySpec :: Maybe Text -> Maybe AppVersionSpecification +querySpec = (readMaybe . toS =<<) + +querySpecD :: AppVersionSpecification -> Maybe Text -> AppVersionSpecification +querySpecD defaultSpec = fromMaybe defaultSpec . querySpec diff --git a/src/Handler/Version.hs b/src/Handler/Version.hs new file mode 100644 index 0000000..d49c8b8 --- /dev/null +++ b/src/Handler/Version.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Handler.Version where + +import Startlude + +import Yesod.Core + +import Constants +import Foundation +import Handler.Types.Status +import Lib.Registry +import Lib.Semver +import Lib.Types.Semver + +getVersionR :: Handler AppVersionRes +getVersionR = pure . AppVersionRes $ registryVersion + +getVersionAppR :: Text -> Handler (Maybe AppVersionRes) +getVersionAppR = getVersionWSpec appResourceDir + +getVersionAgentR :: Handler (Maybe AppVersionRes) +getVersionAgentR = getVersionWSpec sysResourceDir "agent" + +getVersionAppMgrR :: Handler (Maybe AppVersionRes) +getVersionAppMgrR = getVersionWSpec sysResourceDir "appmgr" + +getVersionWSpec :: FilePath -> Text -> Handler (Maybe AppVersionRes) +getVersionWSpec rootDir appId = do + spec <- querySpecD mostRecentVersion <$> lookupGetParam "spec" + appVersions <- registeredAppVersions (toS appId) <$> loadRegistry rootDir + pure . fmap (AppVersionRes . version) $ getSpecifiedAppVersion spec appVersions diff --git a/src/Lib/Error.hs b/src/Lib/Error.hs index 152d14c..d3e9e54 100644 --- a/src/Lib/Error.hs +++ b/src/Lib/Error.hs @@ -46,8 +46,8 @@ toStatus :: S9Error -> Status toStatus = \case PersistentE _ -> status500 -respondStatusException :: MonadHandler m => S9ErrT m a -> m a -respondStatusException action = runExceptT action >>= \case +handleS9ErrT :: MonadHandler m => S9ErrT m a -> m a +handleS9ErrT action = runExceptT action >>= \case Left e -> toStatus >>= sendResponseStatus $ e Right a -> pure a diff --git a/src/Lib/Registry.hs b/src/Lib/Registry.hs new file mode 100644 index 0000000..6d77595 --- /dev/null +++ b/src/Lib/Registry.hs @@ -0,0 +1,77 @@ +module Lib.Registry where + +import Startlude hiding (empty, toList) + +import Data.HashMap.Lazy hiding (mapMaybe) +import qualified GHC.Read (Read (..)) +import qualified GHC.Show (Show (..)) +import System.Directory +import System.FilePath +import Yesod.Core + +import Data.Text (isSuffixOf) + +import Lib.Semver +import Lib.Types.Semver + +newtype S9PK = S9PK String deriving (Eq) +instance Show S9PK where + show (S9PK t) = t <.> "s9pk" + +instance Read S9PK where + readsPrec _ s = [(S9PK . take (m - n) $ s, "") | toS s9pk `isSuffixOf` toS s] + where + m = length s + s9pk = ".s9pk" :: String + n = length s9pk + +instance PathPiece S9PK where + fromPathPiece = readMaybe . toS + toPathPiece = show + +appResourceDir :: FilePath +appResourceDir = "./resources/apps" + +sysResourceDir :: FilePath +sysResourceDir = "./resources/sys" + +appManifestPath :: FilePath +appManifestPath = appResourceDir "apps.yaml" + +appManifestFile :: FilePath +appManifestFile = "apps.yml" + +s9pkExt :: String -> FilePath +s9pkExt = show . S9PK + +type Registry = HashMap String (HashMap AppVersion FilePath) + +newtype RegisteredAppVersion = RegisteredAppVersion (AppVersion, FilePath) +instance HasAppVersion RegisteredAppVersion where + version (RegisteredAppVersion (av, _)) = av + +loadAppRegistry :: MonadIO m => m Registry +loadAppRegistry = loadRegistry appResourceDir + +loadSysRegistry :: MonadIO m => m Registry +loadSysRegistry = loadRegistry sysResourceDir + +loadRegistry :: MonadIO m => FilePath -> m Registry +loadRegistry rootDirectory = liftIO $ do + appDirectories <- getSubDirectories rootDirectory + foldM + ( \registry appId -> do + subdirs <- getSubDirectories (rootDirectory appId) + let validVersions = mapMaybe readMaybe subdirs + let versionedApps = fromList . fmap (id &&& fullS9pk rootDirectory appId) $ validVersions + pure $ insert appId versionedApps registry + ) empty appDirectories + where + getSubDirectories path = listDirectory path >>= filterM (fmap not . doesFileExist) + fullS9pk root appId' appVersion = root appId' show appVersion s9pkExt appId' + +getAppFile :: String -> Registry -> AppVersion -> Maybe FilePath +getAppFile appId r av = lookup av <=< lookup appId $ r + +registeredAppVersions :: String -> Registry -> [RegisteredAppVersion] +registeredAppVersions appId r = maybe [] (fmap RegisteredAppVersion . toList) (lookup appId r) diff --git a/src/Lib/Resource.hs b/src/Lib/Resource.hs deleted file mode 100644 index 453705c..0000000 --- a/src/Lib/Resource.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE TupleSections #-} - -module Lib.Resource where - -import Startlude hiding (empty, toList) - -import Data.HashMap.Lazy hiding (mapMaybe) -import System.Directory -import System.FilePath - -import Lib.Semver -import Lib.Types.Semver - - -resourcePath :: FilePath -resourcePath = "./resources" - -manifestPath :: FilePath -manifestPath = resourcePath "apps.yml" - -manifestFile :: FilePath -manifestFile = "apps.yml" - -s9pkFile :: String -> FilePath -s9pkFile appId = toS appId <.> "s9pk" - -type Registry = HashMap String (HashMap AppVersion FilePath) - -newtype RegisteredAppVersion = RegisteredAppVersion (AppVersion, FilePath) -instance HasAppVersion RegisteredAppVersion where - version (RegisteredAppVersion (av, _)) = av - -loadResources :: MonadIO m => m Registry -loadResources = liftIO $ do - appDirectories <- getSubDirectories resourcePath - foldM - ( \hm appId -> do - subdirs <- getSubDirectories (resourcePath appId) - let validVersions = mapMaybe readMaybe subdirs - let newAppVersions = fromList $ fmap (\v -> (v, resourcePath show v s9pkFile appId)) validVersions - pure $ insert appId newAppVersions hm - ) empty appDirectories - where - getSubDirectories path = listDirectory path >>= filterM (fmap not . doesFileExist) - -getAppFile :: Registry -> String -> AppVersion -> Maybe FilePath -getAppFile r appId av = lookup av <=< lookup appId $ r - -registeredAppVersions :: Registry -> String -> [RegisteredAppVersion] -registeredAppVersions r appId = fromMaybe [] $ fmap RegisteredAppVersion . toList <$> lookup appId r diff --git a/src/Lib/Semver.hs b/src/Lib/Semver.hs index 4efe18d..3befb02 100644 --- a/src/Lib/Semver.hs +++ b/src/Lib/Semver.hs @@ -30,7 +30,7 @@ hasGiven :: (AppVersion -> Word16) -> AppVersion -> AppVersion -> Bool hasGiven projection av = (== projection av) . projection getSpecifiedAppVersion :: HasAppVersion a => AppVersionSpecification -> [a] -> Maybe a -getSpecifiedAppVersion avSpec = appVersionMax . filter (<|| avSpec) -- get the largest thing satisfying the spec. +getSpecifiedAppVersion avSpec = appVersionMax . filter (<|| avSpec) class HasAppVersion a where version :: a -> AppVersion diff --git a/src/Lib/Types/AppsManifest.hs b/src/Lib/Types/AppsManifest.hs deleted file mode 100644 index 67b85b7..0000000 --- a/src/Lib/Types/AppsManifest.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - -module Lib.Types.AppsManifest where - -import Data.HashMap.Strict -import Data.Yaml - -import Lib.Types.Semver -import Startlude - - -type AppsManifest = HashMap Text FullAppManifest -data FullAppManifest = FullAppManifest { name :: Text, appGlobals :: AppGlobals, appVersionDetails :: NonEmpty AppVersionDetails } - -data AppGlobals = AppGlobals - { globalAppTitle :: Text - , globalAppDescriptionShort :: Text - , globalAppDescriptionLong :: Text - , globalAppIconUrl :: Text - } - -instance FromJSON AppGlobals where - parseJSON = withObject "App Globals" $ \o -> do - desc <- o .: "description" - (globalAppDescriptionShort, globalAppDescriptionLong) <- - ( withObject "App Description" $ \d -> do - s <- d .: "short" - l <- d .: "long" - pure (s,l) - ) desc - globalAppTitle <- o .: "title" - globalAppIconUrl <- o .: "icon-url" - pure AppGlobals{..} -instance ToJSON AppGlobals where - toJSON AppGlobals{..} = object - [ "title" .= globalAppTitle - , "descriptionShort" .= globalAppDescriptionShort - , "descriptionLong" .= globalAppDescriptionLong - , "iconUrl" .= globalAppIconUrl - ] - - -data AppVersionDetails = AppVersionDetails - { versionDetailsVersion :: AppVersion - , versionDetailsReleaseNotes :: Text - } deriving (Eq, Ord, Show) -instance FromJSON AppVersionDetails where - parseJSON = withObject "Store App Version Info" $ \o -> do - versionDetailsVersion <- o .: "version" - versionDetailsReleaseNotes <- o .: "release-notes" - pure AppVersionDetails{..} -instance ToJSON AppVersionDetails where - toJSON AppVersionDetails{..} = object - [ "version" .= versionDetailsVersion - , "releaseNotes" .= versionDetailsReleaseNotes - ] diff --git a/src/Lib/Types/Semver.hs b/src/Lib/Types/Semver.hs index 560ff46..82f4e02 100644 --- a/src/Lib/Types/Semver.hs +++ b/src/Lib/Types/Semver.hs @@ -91,6 +91,9 @@ instance FromJSON AppVersionSpecification where requestModifier <- parseJSON . String $ svMod pure $ AppVersionSpecification {..} +mostRecentVersion :: AppVersionSpecification +mostRecentVersion = AppVersionSpecification SVGreaterThanEq $ AppVersion (0,0,0) + ------------------------------------------------------------------------------------------------------------------------ -- Semver RequestModifier ------------------------------------------------------------------------------------------------------------------------ diff --git a/src/Lib/Types/StoreApp.hs b/src/Lib/Types/StoreApp.hs deleted file mode 100644 index fff9d0d..0000000 --- a/src/Lib/Types/StoreApp.hs +++ /dev/null @@ -1,33 +0,0 @@ - -{-# LANGUAGE RecordWildCards #-} -module Lib.Types.StoreApp where - -import Startlude - -import Control.Monad.Fail -import Data.Aeson -import Data.Text - -import Lib.Types.AppsManifest -import Lib.Types.Semver - -data StoreApp = StoreApp - { storeAppId :: Text - , storeAppTitle :: Text - , storeAppDescriptionShort :: Text - , storeAppDescriptionLong :: Text - , storeAppIconUrl :: Text - , storeAppVersions :: NonEmpty AppVersionDetails - } deriving (Eq, Show) - -instance ToJSON StoreApp where - toJSON (StoreApp{..}) = object - [ "id" .= storeAppId - , "title" .= storeAppTitle - , "iconURL" .= storeAppIconUrl - , "description" .= object - [ "short" .= storeAppDescriptionShort - , "long" .= storeAppDescriptionLong - ] - , "versionInfo" .= storeAppVersions - ]