diff --git a/config/routes b/config/routes index 00c3ec2..ff86c7e 100644 --- a/config/routes +++ b/config/routes @@ -1,6 +1,6 @@ --authed -/version/#AppVersion VersionR GET --- /apps AppsManifestR GET --get current apps listing +/version VersionR GET +/apps AppsManifestR GET --get current apps listing -- /apps/#Text/#AppVersion AppR GET --install new app -- /sys/agent/#AppVersion AgentR GET --install new agent version -- /sys/appmgr/#AppVersion AppMgrR GET --install new appmgr version diff --git a/package.yaml b/package.yaml index 8a025c2..08797b7 100644 --- a/package.yaml +++ b/package.yaml @@ -88,6 +88,7 @@ dependencies: - yaml >=0.11 && <0.12 - yesod >=1.6 && <1.7 - yesod-core >=1.6 && <1.7 +- yesod-static - yesod-persistent >= 1.6 && < 1.7 default-extensions: diff --git a/resources/apps.yaml b/resources/apps.yaml new file mode 100644 index 0000000..645eadd --- /dev/null +++ b/resources/apps.yaml @@ -0,0 +1,9 @@ +bitcoind: + title: "Bitcoin Core" + description: + short: "A Bitcoin Full Node" + long: "The bitcoin full node implementation by Bitcoin Core." + version-info: + - version: 0.18.1 + release-notes: "Some stuff" + icon-type: png \ No newline at end of file diff --git a/resources/bitcoind/0.18.1/version.yaml b/resources/bitcoind/0.18.1/version.yaml new file mode 100644 index 0000000..610cb0a --- /dev/null +++ b/resources/bitcoind/0.18.1/version.yaml @@ -0,0 +1,2 @@ +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 new file mode 100644 index 0000000..27b96af --- /dev/null +++ b/resources/bitcoind/app.yaml @@ -0,0 +1,5 @@ +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/src/Application.hs b/src/Application.hs index 0b58091..56dc089 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -50,6 +50,7 @@ import Yesod.Persist.Core -- Import all relevant handler modules here. -- Don't forget to add new modules to your cabal file! import Foundation +import Handler.Apps import Handler.Status import Lib.Ssl import Model diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index 460a7fe..3b7c18c 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} + module Handler.Apps where import Startlude @@ -9,12 +10,20 @@ import Startlude import Control.Monad.Logger import Data.Aeson import qualified Data.ByteString.Lazy as BS +import Data.Conduit +import qualified Data.Conduit.Binary as CB +import System.FilePath +import Yesod.Core import Foundation - +import Lib.Resource pureLog :: Show a => a -> Handler a 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 diff --git a/src/Handler/Status.hs b/src/Handler/Status.hs index a87c34c..3b828c9 100644 --- a/src/Handler/Status.hs +++ b/src/Handler/Status.hs @@ -7,5 +7,5 @@ import Foundation import Handler.Types.Status import Lib.Types.Semver -getVersionR :: AppVersion -> Handler AppVersionRes -getVersionR = pure . AppVersionRes -- $ registryVersion +getVersionR :: Handler AppVersionRes +getVersionR = pure . AppVersionRes $ registryVersion diff --git a/src/Handler/Types/Apps.hs b/src/Handler/Types/Apps.hs index 5ecbfcc..c5f3dcb 100644 --- a/src/Handler/Types/Apps.hs +++ b/src/Handler/Types/Apps.hs @@ -4,79 +4,16 @@ module Handler.Types.Apps where import Startlude import Data.Aeson -import Data.Time.ISO8601 import Yesod.Core.Content -import Lib.Types.Semver -import Lib.Types.ServerApp +import Lib.Types.StoreApp newtype AvailableAppsRes = AvailableAppsRes - { availableApps :: [(StoreApp, Maybe AppVersion)] + { availableApps :: [StoreApp] } deriving (Eq, Show) instance ToJSON AvailableAppsRes where - toJSON = toJSON . fmap toJSON' . availableApps - where - toJSON' (StoreApp{..}, version) = object - [ "id" .= storeAppId - , "title" .= storeAppTitle - , "versionInstalled" .= version - , "versionLatest" .= (storeAppVersionInfoVersion . extract) storeAppVersions - , "iconURL" .= storeAppIconUrl - , "descriptionShort" .= storeAppDescriptionShort - ] + toJSON = toJSON . availableApps instance ToTypedContent AvailableAppsRes where toTypedContent = toTypedContent . toJSON instance ToContent AvailableAppsRes where toContent = toContent . toJSON - -newtype AvailableAppFullRes = AvailableAppFullRes - { availableAppFull :: (StoreApp, Maybe AppVersion) - } deriving (Eq, Show) -instance ToJSON AvailableAppFullRes where - toJSON = toJSON' . availableAppFull - where - toJSON' (StoreApp{..}, version) = object - [ "id" .= storeAppId - , "title" .= storeAppTitle - , "versionInstalled" .= version - , "versionLatest" .= (storeAppVersionInfoVersion . extract) storeAppVersions - , "iconURL" .= storeAppIconUrl - , "descriptionShort" .= storeAppDescriptionShort - , "descriptionLong" .= storeAppDescriptionLong - , "versions" .= storeAppVersions - ] -instance ToContent AvailableAppFullRes where - toContent = toContent . toJSON -instance ToTypedContent AvailableAppFullRes where - toTypedContent = toTypedContent . toJSON - -newtype InstalledAppRes = InstalledAppRes - { installedApp :: (StoreApp, ServerApp, AppStatus, UTCTime) - } deriving (Eq, Show) -instance ToJSON InstalledAppRes where - toJSON = toJSON' . installedApp - where - toJSON' (store, server, status, time) = object - [ "id" .= storeAppId store - , "title" .= storeAppTitle store - , "versionLatest" .= (storeAppVersionInfoVersion . extract) (storeAppVersions store) - , "versionInstalled" .= serverAppVersionInstalled server - , "iconURL" .= storeAppIconUrl store - , "torAddress" .= serverAppTorService server - , "status" .= status - , "statusAt" .= formatISO8601Javascript time - ] -instance ToTypedContent InstalledAppRes where - toTypedContent = toTypedContent . toJSON -instance ToContent InstalledAppRes where - toContent = toContent . toJSON - -data InstallNewAppReq = InstallNewAppReq - { installNewAppId :: Text - , installNewAppVersion :: Text - } deriving (Eq, Show) -instance FromJSON InstallNewAppReq where - parseJSON = withObject "Install New App Request" $ \o -> do - installNewAppId <- o .: "id" - installNewAppVersion <- o .: "version" - pure InstallNewAppReq{..} diff --git a/src/Handler/Types/Status.hs b/src/Handler/Types/Status.hs index 73b42d9..2f3c2bf 100644 --- a/src/Handler/Types/Status.hs +++ b/src/Handler/Types/Status.hs @@ -1,31 +1,14 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} module Handler.Types.Status where -import Startlude +import Startlude -import Data.Aeson -import Data.Text -import Yesod.Core.Content +import Data.Aeson +import Data.Text +import Yesod.Core.Content -import Lib.Types.ServerApp -import Lib.Types.Semver - -data ServerRes = ServerRes - { serverStatus :: AppStatus - , serverVersion :: AppVersion - , serverSpecs :: Value - } deriving (Eq, Show) -instance ToJSON ServerRes where - toJSON ServerRes{..} = object - [ "status" .= toUpper (show serverStatus) - , "versionInstalled" .= serverVersion - , "specs" .= serverSpecs - , "versionLatest" .= serverVersion -- TODO: change this. - ] -instance ToTypedContent ServerRes where - toTypedContent = toTypedContent . toJSON -instance ToContent ServerRes where - toContent = toContent . toJSON +import Lib.Types.Semver +import Lib.Types.StoreApp newtype AppVersionRes = AppVersionRes { unAppVersionRes :: AppVersion } deriving (Eq, Show) diff --git a/src/Lib/Resource.hs b/src/Lib/Resource.hs new file mode 100644 index 0000000..ae15619 --- /dev/null +++ b/src/Lib/Resource.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE TupleSections #-} + +module Lib.Resource where + +import Startlude hiding (empty) + +import Data.Aeson +import Data.HashMap.Lazy hiding (mapMaybe) +import System.Directory +import System.FilePath + +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) + +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 (, 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 = do + s9pk <- lookup av <=< lookup appId $ r + pure $ resourcePath appId show av s9pk diff --git a/src/Lib/Types/Api.hs b/src/Lib/Types/Api.hs deleted file mode 100644 index 18cad2e..0000000 --- a/src/Lib/Types/Api.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE RecordWildCards #-} -module Lib.Types.Api where - -import Startlude - -import Data.Aeson - -import Orphans.Yesod () - --- data PostWifiRes; TODO: do we need the PostWifiRes or equivalent?? -data AddWifiReq = AddWifiReq - { addWifiSsid :: Text - , addWifiPass :: Text - } deriving (Eq, Show) -instance FromJSON AddWifiReq where - parseJSON = withObject "add wifi req" $ \o -> do - addWifiSsid <- o .: "ssid" - addWifiPass <- o .: "password" - pure AddWifiReq{..} - -newtype EnableWifiReq = EnableWifiReq - { enableWifiSsid :: Text - } deriving (Eq, Show) -instance FromJSON EnableWifiReq where - parseJSON = withObject "enable wifi req" $ \o -> do - enableWifiSsid <- o .: "ssid" - pure $ EnableWifiReq {..} diff --git a/src/Lib/Types/AppsManifest.hs b/src/Lib/Types/AppsManifest.hs new file mode 100644 index 0000000..67b85b7 --- /dev/null +++ b/src/Lib/Types/AppsManifest.hs @@ -0,0 +1,56 @@ +{-# 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 cb35ecb..1c3faa1 100644 --- a/src/Lib/Types/Semver.hs +++ b/src/Lib/Types/Semver.hs @@ -17,6 +17,10 @@ import Yesod.Core newtype AppVersion = AppVersion { unAppVersion :: (Word16, Word16, Word16) } deriving (Eq, Ord) +instance Hashable AppVersion where + hash (AppVersion (a, b, c)) = (2 ^ c) * (3 ^ b) * (5 ^ a) + hashWithSalt _ = hash + instance Read AppVersion where readsPrec _ s = case traverse (readMaybe . toS) $ split (=='.') (toS s) of Just [major, minor, patch] -> [(AppVersion (major, minor, patch), "")] diff --git a/src/Lib/Types/ServerApp.hs b/src/Lib/Types/ServerApp.hs deleted file mode 100644 index 687064b..0000000 --- a/src/Lib/Types/ServerApp.hs +++ /dev/null @@ -1,57 +0,0 @@ - -{-# LANGUAGE RecordWildCards #-} -module Lib.Types.ServerApp where - -import Startlude - -import Control.Monad.Fail -import Data.Aeson -import Data.Text - -import Lib.Types.Semver - -data StoreApp = StoreApp - { storeAppId :: Text - , storeAppTitle :: Text - , storeAppDescriptionShort :: Text - , storeAppDescriptionLong :: Text - , storeAppIconUrl :: Text - , storeAppVersions :: NonEmpty StoreAppVersionInfo - } deriving (Eq, Show) - -data StoreAppVersionInfo = StoreAppVersionInfo - { storeAppVersionInfoVersion :: AppVersion - , storeAppVersionInfoReleaseNotes :: Text - } deriving (Eq, Ord, Show) -instance FromJSON StoreAppVersionInfo where - parseJSON = withObject "Store App Version Info" $ \o -> do - storeAppVersionInfoVersion <- o .: "version" - storeAppVersionInfoReleaseNotes <- o .: "release-notes" - pure StoreAppVersionInfo{..} -instance ToJSON StoreAppVersionInfo where - toJSON StoreAppVersionInfo{..} = object - [ "version" .= storeAppVersionInfoVersion - , "releaseNotes" .= storeAppVersionInfoReleaseNotes - ] - -data ServerApp = ServerApp - { serverAppId :: Text - , serverAppVersionInstalled :: AppVersion - , serverAppTorService :: Text - , serverAppIsConfigured :: Bool - } deriving (Eq, Show) - - -data AppStatus = Running | Stopped | Restarting | Removing | Dead deriving (Eq, Show) -instance ToJSON AppStatus where - toJSON = String . toUpper . show -instance FromJSON AppStatus where - parseJSON = withText "health status" $ \case - "RUNNING" -> pure Running - "STOPPED" -> pure Stopped - "RESTARTING" -> pure Restarting - "REMOVING" -> pure Removing - "DEAD" -> pure Dead - _ -> fail "unknown status" - -data AppAction = Start | Stop deriving (Eq, Show) diff --git a/src/Lib/Types/StoreApp.hs b/src/Lib/Types/StoreApp.hs new file mode 100644 index 0000000..fff9d0d --- /dev/null +++ b/src/Lib/Types/StoreApp.hs @@ -0,0 +1,33 @@ + +{-# 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 + ] diff --git a/src/Startlude.hs b/src/Startlude.hs index 9ef788c..fff9cd5 100644 --- a/src/Startlude.hs +++ b/src/Startlude.hs @@ -10,8 +10,7 @@ import Control.Error.Util as X import Data.Coerce as X import Data.String as X (String, fromString) import Data.Time.Clock as X -import Protolude as X hiding (bool, hush, isLeft, isRight, - note, tryIO) +import Protolude as X hiding (bool, hush, isLeft, isRight, note, tryIO, (<.>)) id :: a -> a id = identity diff --git a/test/Live/UpdateAgent.hs b/test/Live/UpdateAgent.hs index 89457fc..ce3e1eb 100644 --- a/test/Live/UpdateAgent.hs +++ b/test/Live/UpdateAgent.hs @@ -1,7 +1,7 @@ module Live.UpdateAgent where import Application -import Lib.Types.ServerApp +import Lib.Types.StoreApp import Lib.UpdateAgent import Startlude