From d8b5d3e193581cad00bb59020923c8fe4e0fda4a Mon Sep 17 00:00:00 2001 From: Aaron Greenspan Date: Thu, 2 Jan 2020 14:42:59 -0700 Subject: [PATCH] adds icons endpoint --- config/routes | 1 + package.yaml | 1 + resources/icons/bitcoind.png | 0 resources/sys/agent/0.0.0/agent | 0 src/Application.hs | 1 + src/Constants.hs | 2 +- src/Foundation.hs | 1 + src/Handler/Apps.hs | 27 ++++---- src/Handler/Icons.hs | 26 ++++++++ src/Handler/Version.hs | 17 +++--- src/Lib/Registry.hs | 105 ++++++++++++++++---------------- 11 files changed, 105 insertions(+), 76 deletions(-) create mode 100644 resources/icons/bitcoind.png create mode 100644 resources/sys/agent/0.0.0/agent create mode 100644 src/Handler/Icons.hs diff --git a/config/routes b/config/routes index 2d05274..8045cf3 100644 --- a/config/routes +++ b/config/routes @@ -8,6 +8,7 @@ /sys/version/appmgr VersionAppMgrR GET --get most recent appmgr version /sys/version/torrc VersionTorrcR GET --get most recent torrc version +/icons/#PNG IconsR GET -- get icons !/apps/#S9PK AppR GET --get most recent appId at appversion spec, defaults to >=0.0.0 -- ?spec={semver-spec} /sys/agent AgentR GET --get most recent agent at appversion -- ?spec={semver-spec} /sys/appmgr AppMgrR GET --get most recent appmgr at appversion -- ?spec={semver-spec} diff --git a/package.yaml b/package.yaml index 07c9eb5..6af4e39 100644 --- a/package.yaml +++ b/package.yaml @@ -68,6 +68,7 @@ dependencies: - process - protolude - safe +- singletons - split - template-haskell - text >=0.11 && <2.0 diff --git a/resources/icons/bitcoind.png b/resources/icons/bitcoind.png new file mode 100644 index 0000000..e69de29 diff --git a/resources/sys/agent/0.0.0/agent b/resources/sys/agent/0.0.0/agent new file mode 100644 index 0000000..e69de29 diff --git a/src/Application.hs b/src/Application.hs index 0f92fa4..598e5d5 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -51,6 +51,7 @@ import Yesod.Persist.Core -- Don't forget to add new modules to your cabal file! import Foundation import Handler.Apps +import Handler.Icons import Handler.Version import Lib.Ssl import Model diff --git a/src/Constants.hs b/src/Constants.hs index 49f8034..a3019da 100644 --- a/src/Constants.hs +++ b/src/Constants.hs @@ -12,7 +12,7 @@ sslPath :: FilePath sslPath = "/var/ssl" resourcesPath :: FilePath -resourcesPath = "/var/www/html/resources" +resourcesPath = "./resources" -- "/var/www/html/resources" registryVersion :: AppVersion registryVersion = fromJust . parseMaybe parseJSON . String . toS . showVersion $ version diff --git a/src/Foundation.hs b/src/Foundation.hs index 819441f..833d0e9 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -24,6 +24,7 @@ import Settings -- starts running, such as database connections. Every handler will have -- access to the data present here. + data AgentCtx = AgentCtx { appSettings :: AppSettings , appConnPool :: ConnectionPool -- ^ Database connection pool. diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index b496c0a..cced7a8 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} @@ -34,31 +35,29 @@ instance Show FileExtension where show (FileExtension f Nothing) = f show (FileExtension f (Just e)) = f <.> e -getImageR :: Handler TypedContent -getImageR = getApp sysResourceDir "image" - getAppsManifestR :: Handler TypedContent getAppsManifestR = respondSource typePlain $ CB.sourceFile appManifestPath .| awaitForever sendChunkBS +getImageR :: Handler TypedContent +getImageR = getApp sysResourceDir ("image" :: Extension "") + getAgentR :: Handler TypedContent -getAgentR = getApp sysResourceDir "agent" +getAgentR = getApp sysResourceDir ("agent" :: Extension "") getAppMgrR :: Handler TypedContent -getAppMgrR = getApp sysResourceDir "appmgr" +getAppMgrR = getApp sysResourceDir ("appmgr" :: Extension "") getTorrcR :: Handler TypedContent -getTorrcR = getApp sysResourceDir "torrc" +getTorrcR = getApp sysResourceDir ("torrc" :: Extension "") -getAppR :: S9PK -> Handler TypedContent -getAppR (S9PK appId) = getApp appResourceDir appId +getAppR :: Extension "s9pk" -> Handler TypedContent +getAppR = getApp appResourceDir -getApp :: FilePath -> FilePath -> Handler TypedContent -getApp rootDir appId = do +getApp :: KnownSymbol a => FilePath -> Extension a -> Handler TypedContent +getApp rootDir ext = do spec <- querySpecD mostRecentVersion <$> lookupGetParam "spec" - reg <- loadRegistry rootDir - putStrLn ("got registry" :: String) - let appVersions = registeredAppVersions appId reg - putStrLn $ "valid appversion for " <> appId <> ": " <> show (fmap version appVersions) + appVersions <- liftIO $ getAvailableAppVersions rootDir ext + putStrLn $ "valid appversion for " <> (show ext :: String) <> ": " <> show appVersions case getSpecifiedAppVersion spec appVersions of Nothing -> notFound Just (RegisteredAppVersion (_, filePath)) -> do diff --git a/src/Handler/Icons.hs b/src/Handler/Icons.hs new file mode 100644 index 0000000..0cf44ad --- /dev/null +++ b/src/Handler/Icons.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} + +module Handler.Icons where + +import Startlude + +import Data.Conduit +import qualified Data.Conduit.Binary as CB +import System.Directory +import Yesod.Core + +import Foundation +import Lib.Registry + +getIconsR :: Extension "png" -> Handler TypedContent +getIconsR ext = do + mPng <- liftIO $ getUnversionedFileFromDir iconsResourceDir ext + case mPng of + Nothing -> notFound + Just pngPath -> do + putStrLn @Text $ show pngPath + exists <- liftIO $ doesFileExist pngPath + if exists + then respondSource typePlain $ CB.sourceFile pngPath .| awaitForever sendChunkBS + else notFound diff --git a/src/Handler/Version.hs b/src/Handler/Version.hs index 90633af..e1cf92d 100644 --- a/src/Handler/Version.hs +++ b/src/Handler/Version.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} module Handler.Version where @@ -16,19 +17,21 @@ getVersionR :: Handler AppVersionRes getVersionR = pure . AppVersionRes $ registryVersion getVersionAppR :: Text -> Handler (Maybe AppVersionRes) -getVersionAppR = getVersionWSpec appResourceDir +getVersionAppR appId = getVersionWSpec appResourceDir appExt + where + appExt = Extension (toS appId) :: Extension "s9pk" getVersionAgentR :: Handler (Maybe AppVersionRes) -getVersionAgentR = getVersionWSpec sysResourceDir "agent" +getVersionAgentR = getVersionWSpec sysResourceDir ("agent" :: Extension "") getVersionAppMgrR :: Handler (Maybe AppVersionRes) -getVersionAppMgrR = getVersionWSpec sysResourceDir "appmgr" +getVersionAppMgrR = getVersionWSpec sysResourceDir ("appmgr" :: Extension "") getVersionTorrcR :: Handler (Maybe AppVersionRes) -getVersionTorrcR = getVersionWSpec sysResourceDir "torrc" +getVersionTorrcR = getVersionWSpec sysResourceDir ("torrc" :: Extension "") -getVersionWSpec :: FilePath -> Text -> Handler (Maybe AppVersionRes) -getVersionWSpec rootDir appId = do +getVersionWSpec :: KnownSymbol a => FilePath -> Extension a -> Handler (Maybe AppVersionRes) +getVersionWSpec rootDir ext = do spec <- querySpecD mostRecentVersion <$> lookupGetParam "spec" - appVersions <- registeredAppVersions (toS appId) <$> loadRegistry rootDir + appVersions <- liftIO $ getAvailableAppVersions rootDir ext pure . fmap (AppVersionRes . version) $ getSpecifiedAppVersion spec appVersions diff --git a/src/Lib/Registry.hs b/src/Lib/Registry.hs index d6e831f..284ffd0 100644 --- a/src/Lib/Registry.hs +++ b/src/Lib/Registry.hs @@ -1,6 +1,11 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + module Lib.Registry where -import Startlude hiding (empty, toList) +import Startlude import Data.HashMap.Lazy hiding (mapMaybe) import qualified GHC.Read (Read (..)) @@ -14,22 +19,6 @@ import Data.Text (isSuffixOf) import Constants import Lib.Semver import Lib.Types.Semver -import Util.Function - -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 = resourcesPath "apps" @@ -37,57 +26,65 @@ appResourceDir = resourcesPath "apps" sysResourceDir :: FilePath sysResourceDir = resourcesPath "sys" +iconsResourceDir :: FilePath +iconsResourceDir = resourcesPath "icons" + appManifestPath :: FilePath appManifestPath = appResourceDir appManifestFile appManifestFile :: FilePath appManifestFile = "apps.yaml" -s9pkExt :: String -> FilePath -s9pkExt = show . S9PK - type Registry = HashMap String (HashMap AppVersion FilePath) -newtype RegisteredAppVersion = RegisteredAppVersion (AppVersion, FilePath) +newtype RegisteredAppVersion = RegisteredAppVersion (AppVersion, FilePath) deriving (Eq, Show) 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 - putStrLn $ "got appDirectories for " <> rootDirectory <> ": " <> show appDirectories - foldM - ( \registry appId -> do - subdirs <- getSubDirectories (rootDirectory appId) - putStrLn $ "got appDirectories for " <> (rootDirectory appId) <> ": " <> show subdirs - let validVersions = mapMaybe readMaybe subdirs - versionApps <- for validVersions $ \v -> - getAppFileFromDir rootDirectory appId v - >>= \case - Nothing -> pure Nothing - Just appFile -> pure . Just $ (v, rootDirectory appId show v appFile) - pure $ insert appId (fromList . catMaybes $ versionApps) registry - ) empty appDirectories +getAvailableAppVersions :: KnownSymbol a => FilePath -> Extension a -> IO [RegisteredAppVersion] +getAvailableAppVersions rootDirectory ext@(Extension appId) = do + versions <- mapMaybe readMaybe <$> getSubDirectories (rootDirectory appId) + fmap catMaybes . for versions $ \v -> + getVersionedFileFromDir rootDirectory ext v + >>= \case + Nothing -> pure Nothing + Just appFile -> pure . Just $ RegisteredAppVersion (v, appFile) where - getSubDirectories path = listDirectory path >>= filterM (doesDirectoryExist . (path )) + getSubDirectories path = (fmap (fromRight []) . try @SomeException $ listDirectory path) >>= filterM (doesDirectoryExist . (path )) +-- /root/appId/version/appId.ext +getVersionedFileFromDir :: KnownSymbol a => FilePath -> Extension a -> AppVersion -> IO (Maybe FilePath) +getVersionedFileFromDir rootDirectory ext@(Extension appId) v = getUnversionedFileFromDir (rootDirectory appId show v) ext -getAppFileFromDir :: String -> String -> AppVersion -> IO (Maybe FilePath) -getAppFileFromDir rootDirectory appId v = do - dirContents <- listDirectory (rootDirectory appId show v) - pure $ find (isPrefixOf appId) dirContents +-- /root/appId.ext +getUnversionedFileFromDir :: KnownSymbol a => FilePath -> Extension a -> IO (Maybe FilePath) +getUnversionedFileFromDir rootDirectory appExt = fmap (join . hush) . try @SomeException $ do + dirContents <- listDirectory rootDirectory + pure . fmap (rootDirectory ) $ find (== show appExt) dirContents -getAppFile :: String -> Registry -> AppVersion -> Maybe FilePath -getAppFile appId r av = lookup av <=< lookup appId $ r +newtype Extension (a :: Symbol) = Extension String deriving (Eq) +type S9PK = Extension "s9pk" +type PNG = Extension "png" -registeredAppVersions :: String -> Registry -> [RegisteredAppVersion] -registeredAppVersions appId r = maybe [] (fmap RegisteredAppVersion . toList) (lookup appId r) +instance IsString (Extension a) where + fromString = Extension -findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a) -findM = fmap headMay .* filterM +def :: Extension a +def = Extension "" + +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 = [(Extension . take (m - n - 1) $ s, "") | toS ext' `isSuffixOf` toS s] + where + m = length s + ext' = extension (def :: Extension a) + n = length ext' + +instance KnownSymbol a => PathPiece (Extension a) where + fromPathPiece = readMaybe . toS + toPathPiece = show