resource gathering

config/routes

@@ -1,6 +1,6 @@
 --authed
-/version/#AppVersion                         VersionR           GET
+/version                            VersionR           GET
--- /apps                            AppsManifestR      GET --get current apps listing
+/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

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:

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

resources/bitcoind/0.18.1/version.yaml

@@ -0,0 +1,2 @@
+version: 0.18.1
+release-notes: "Some stuff"

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

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

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

src/Handler/Status.hs

@@ -7,5 +7,5 @@ import           Foundation
 import           Handler.Types.Status
 import           Lib.Types.Semver
 
-getVersionR :: AppVersion -> Handler AppVersionRes
+getVersionR :: Handler AppVersionRes
-getVersionR = pure . AppVersionRes -- $ registryVersion
+getVersionR = pure . AppVersionRes $ registryVersion

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.StoreApp
-import           Lib.Types.ServerApp
 
 newtype AvailableAppsRes = AvailableAppsRes
-    { availableApps :: [(StoreApp, Maybe AppVersion)]
+    { availableApps :: [StoreApp]
     } deriving (Eq, Show)
 instance ToJSON AvailableAppsRes where
-    toJSON = toJSON . fmap toJSON' . availableApps
+    toJSON = toJSON . availableApps
-        where
-            toJSON' (StoreApp{..}, version) = object
-                [ "id" .= storeAppId
-                , "title" .= storeAppTitle
-                , "versionInstalled" .= version
-                , "versionLatest" .= (storeAppVersionInfoVersion . extract) storeAppVersions
-                , "iconURL" .= storeAppIconUrl
-                , "descriptionShort" .= storeAppDescriptionShort
-                ]
 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{..}

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.Aeson
-import Data.Text
+import           Data.Text
-import Yesod.Core.Content
+import           Yesod.Core.Content
 
-import Lib.Types.ServerApp
+import           Lib.Types.Semver
-import Lib.Types.Semver
+import           Lib.Types.StoreApp
-
-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
 
 newtype AppVersionRes = AppVersionRes
     { unAppVersionRes :: AppVersion } deriving (Eq, Show)

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

src/Lib/Types/Api.hs

@@ -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 {..}

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

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), "")]

src/Lib/Types/ServerApp.hs

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

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

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,
+import           Protolude          as X hiding (bool, hush, isLeft, isRight, note, tryIO, (<.>))
-                                          note, tryIO)
 
 id :: a -> a
 id = identity

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