scaffolding ready for s9pks

src/Constants.hs

@@ -4,15 +4,18 @@ import           Data.Aeson
 import           Data.Aeson.Types
 import           Data.Maybe
 import           Data.Version          (showVersion)
-import           Lib.Types.ServerApp
+import           Lib.Types.Semver
 import           Paths_start9_registry (version)
 import           Startlude
 
-configBasePath :: FilePath
-configBasePath = "./config"
+configPath :: FilePath
+configPath = "./config"
+
+resourcesPath :: FilePath
+resourcesPath = "./resources"
 
 registryVersion :: AppVersion
 registryVersion = fromJust . parseMaybe parseJSON . String . toS . showVersion $ version
 
 getRegistryHostname :: IsString a => a
-getRegistryHostname = "registry"
+getRegistryHostname = "registry.start9labs.com"

src/Foundation.hs

@@ -11,6 +11,7 @@ import           Startlude
 import           Control.Monad.Logger (LogSource)
 import           Data.IORef
 import           Database.Persist.Sql
+import           Lib.Types.Semver
 import           Yesod.Core
 import           Yesod.Core.Types     (Logger)
 import qualified Yesod.Core.Unsafe    as Unsafe

src/Handler/Status.hs

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

src/Handler/Types/Apps.hs

@@ -7,6 +7,7 @@ import           Data.Aeson
 import           Data.Time.ISO8601
 import           Yesod.Core.Content
 
+import           Lib.Types.Semver
 import           Lib.Types.ServerApp
 
 newtype AvailableAppsRes = AvailableAppsRes

src/Handler/Types/Status.hs

@@ -8,6 +8,7 @@ import Data.Text
 import Yesod.Core.Content
 
 import Lib.Types.ServerApp
+import Lib.Types.Semver
 
 data ServerRes = ServerRes
     { serverStatus  :: AppStatus

src/Lib/Semver.hs

@@ -0,0 +1,45 @@
+module Lib.Semver where
+
+import           Startlude
+
+import           Lib.Types.Semver
+
+(<||) :: HasAppVersion a => a -> AppVersionSpecification -> Bool
+(<||) a (AppVersionSpecification SVEquals av1)        = version a == av1
+(<||) a (AppVersionSpecification SVLessThan av1)      = version a < av1
+(<||) a (AppVersionSpecification SVGreaterThan av1)   = version a > av1
+(<||) a (AppVersionSpecification SVLessThanEq av1)    = version a <= av1
+(<||) a (AppVersionSpecification SVGreaterThanEq av1) = version a >= av1
+(<||) a (AppVersionSpecification SVGreatestWithMajor av1)
+    = major av == major av1 && av >= av1
+    where
+        av = version a
+(<||) a (AppVersionSpecification SVGreatestWithMajorMinor av1)
+    = major av == major av1 && minor av == minor av1 && av >= av1
+    where
+        av = version a
+
+major :: AppVersion -> Word16
+major (AppVersion (a, _, _)) = a
+minor :: AppVersion -> Word16
+minor (AppVersion (_, a, _)) = a
+patch :: AppVersion -> Word16
+patch (AppVersion (_, _, a)) = a
+
+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.
+
+class HasAppVersion a where
+    version :: a -> AppVersion
+
+instance HasAppVersion AppVersion where
+    version = id
+
+appVersionMax :: HasAppVersion a => [a] -> Maybe a
+appVersionMax [] = Nothing
+appVersionMax as = Just $ maximumBy (\a1 a2 -> version a1 `compare` version a2) as
+
+

src/Lib/Ssl.hs

@@ -15,7 +15,7 @@ import           Constants
 -- openssl x509 -req -in certificate.csr -signkey key.pem -out certificate.pem
 
 sslBaseLocation :: FilePath
-sslBaseLocation = configBasePath </> "ssl"
+sslBaseLocation = configPath </> "ssl"
 
 sslKeyLocation :: FilePath
 sslKeyLocation = sslBaseLocation </> "key.pem"

src/Lib/Types/Semver.hs

@@ -0,0 +1,90 @@
+{-# LANGUAGE QuasiQuotes     #-}
+{-# LANGUAGE RecordWildCards #-}
+module Lib.Types.Semver where
+
+import           Startlude               hiding (break)
+
+import qualified GHC.Read                (Read (..))
+import qualified GHC.Show                (Show (..))
+
+import           Control.Monad.Fail
+import           Data.Aeson
+import           Data.Char               (isDigit)
+import           Data.String.Interpolate
+import           Data.Text
+import           Yesod.Core
+
+newtype AppVersion = AppVersion
+    { unAppVersion :: (Word16, Word16, Word16) } deriving (Eq, Ord)
+
+instance Read AppVersion where
+    readsPrec _ s = case traverse (readMaybe . toS) $ split (=='.') (toS s) of
+        Just [major, minor, patch] -> [(AppVersion (major, minor, patch), "")]
+        _                          -> []
+instance PathPiece AppVersion where
+    fromPathPiece = readMaybe . toS
+    toPathPiece = show
+
+instance Show AppVersion where
+    show (AppVersion (a, b, c)) = [i|#{a}.#{b}.#{c}|]
+instance IsString AppVersion where
+    fromString s = case traverse (readMaybe . toS) $ split (=='.') (toS s) of
+        Just [major, minor, patch] -> AppVersion (major, minor, patch)
+        _                          -> panic . toS $ "Invalid App Version: " <> s
+instance ToJSON AppVersion where
+    toJSON av = String . toS $ let (a,b,c) = unAppVersion av in [i|#{a}.#{b}.#{c}|]
+instance FromJSON AppVersion where
+    parseJSON = withText "app version" $ \t ->
+        case splitOn "." t of
+            [a, b, c] ->
+                case traverse (decode . toS) [a, b, c] of
+                    Just [a', b', c'] -> pure $ AppVersion (a', b', c')
+                    _                 -> fail "non word16 versioning"
+            _ -> fail "unknown versioning"
+instance ToTypedContent AppVersion where
+    toTypedContent = toTypedContent . toJSON
+instance ToContent AppVersion where
+    toContent = toContent . toJSON
+
+(\\) :: AppVersion -> AppVersion -> (Word16, Word16, Word16)
+(\\) (AppVersion (a, b, c)) (AppVersion (a1, b1, c1)) = (a `diffy` a1, b `diffy` b1, c `diffy` c1)
+    where
+        d `diffy` d1 = fromIntegral . abs $ (fromIntegral d :: Integer) - (fromIntegral d1 :: Integer)
+
+data AppVersionSpecification = AppVersionSpecification
+    { requestModifier :: SemverRequestModifier
+    , baseVersion     :: AppVersion
+    }
+
+instance Show AppVersionSpecification where
+    show (AppVersionSpecification r b) = show r <> show b
+instance ToJSON AppVersionSpecification where
+    toJSON = String . show
+instance FromJSON AppVersionSpecification where
+    parseJSON = withText "app version spec" $ \t -> do
+        let (svMod, version) = break isDigit t
+        baseVersion <- parseJSON . String $ version
+        requestModifier <- parseJSON . String $ svMod
+        pure $ AppVersionSpecification {..}
+
+data SemverRequestModifier = SVEquals | SVLessThan | SVGreaterThan | SVGreatestWithMajor | SVGreatestWithMajorMinor | SVLessThanEq | SVGreaterThanEq deriving (Eq, Bounded, Enum)
+instance Show SemverRequestModifier where
+    show SVEquals                 = "="
+    show SVLessThan               = "<"
+    show SVGreaterThan            = ">"
+    show SVGreatestWithMajor      = "~"
+    show SVGreatestWithMajorMinor = "^"
+    show SVLessThanEq             = "<="
+    show SVGreaterThanEq          = ">="
+
+instance FromJSON SemverRequestModifier where
+    parseJSON = withText "semver request modifier" $ \case
+        ""   -> pure SVGreatestWithMajorMinor
+        "="  -> pure SVEquals
+        "<"  -> pure SVLessThan
+        ">"  -> pure SVGreaterThan
+        "~"  -> pure SVGreatestWithMajor
+        "^"  -> pure SVGreatestWithMajorMinor
+        "<=" -> pure SVLessThanEq
+        ">=" -> pure SVGreaterThanEq
+        _    -> fail "invalid semver request modifier"

src/Lib/Types/ServerApp.hs

@@ -1,17 +1,14 @@
-{-# LANGUAGE QuasiQuotes     #-}
+
 {-# LANGUAGE RecordWildCards #-}
 module Lib.Types.ServerApp where
 
-import           Startlude               hiding (break)
-
-import qualified GHC.Show                (Show (..))
+import           Startlude
 
 import           Control.Monad.Fail
 import           Data.Aeson
-import           Data.Char               (isDigit)
-import           Data.String.Interpolate
 import           Data.Text
-import           Yesod.Core
+
+import           Lib.Types.Semver
 
 data StoreApp = StoreApp
     { storeAppId               :: Text
@@ -44,83 +41,6 @@ data ServerApp = ServerApp
     , serverAppIsConfigured     :: Bool
     } deriving (Eq, Show)
 
-data SemverRequestModifier = SVEquals | SVLessThan | SVGreaterThan | SVMinMinor | SVMinPatch | SVLessThanEq | SVGreaterThanEq deriving (Eq, Bounded, Enum)
-instance Show SemverRequestModifier where
-    show SVEquals        = "="
-    show SVLessThan      = "<"
-    show SVGreaterThan   = ">"
-    show SVMinMinor      = "~"
-    show SVMinPatch      = "^"
-    show SVLessThanEq    = "<="
-    show SVGreaterThanEq = ">="
-
-instance FromJSON SemverRequestModifier where
-    parseJSON = withText "semver request modifier" $ \case
-        ""   -> pure SVMinPatch
-        "="  -> pure SVEquals
-        "<"  -> pure SVLessThan
-        ">"  -> pure SVGreaterThan
-        "~"  -> pure SVMinMinor
-        "^"  -> pure SVMinPatch
-        "<=" -> pure SVLessThanEq
-        ">=" -> pure SVGreaterThanEq
-        _    -> fail "invalid semver request modifier"
-
-data AppVersionSpecification = AppVersionSpecification
-    { requestModifier :: SemverRequestModifier
-    , baseVersion     :: AppVersion
-    }
-
-instance Show AppVersionSpecification where
-    show (AppVersionSpecification r b) = show r <> show b
-instance ToJSON AppVersionSpecification where
-    toJSON = String . show
-instance FromJSON AppVersionSpecification where
-    parseJSON = withText "app version spec" $ \t -> do
-        let (svMod, version) = break isDigit t
-        baseVersion <- parseJSON . String $ version
-        requestModifier <- parseJSON . String $ svMod
-        pure $ AppVersionSpecification {..}
-
-(<||) :: AppVersion -> AppVersionSpecification -> Bool
-(<||) av (AppVersionSpecification SVEquals av1)        = av == av1
-(<||) av (AppVersionSpecification SVLessThan av1)      = av < av1
-(<||) av (AppVersionSpecification SVGreaterThan av1)   = av > av1
-(<||) av (AppVersionSpecification SVLessThanEq av1)    = av <= av1
-(<||) av (AppVersionSpecification SVGreaterThanEq av1) = av >= av1
-(<||) (AppVersion (a,b,_)) (AppVersionSpecification SVMinMinor (AppVersion (a1, b1, _)))
-    = a == a1 && b >= b1
-(<||) (AppVersion (a,b,c)) (AppVersionSpecification SVMinPatch (AppVersion (a1, b1, c1)))
-    = a == a1 && b == b1 && c >= c1
-
-
-newtype AppVersion = AppVersion
-    { unAppVersion :: (Word16, Word16, Word16) } deriving (Eq, Ord)
-instance Show AppVersion where
-    show (AppVersion (a, b, c)) = [i|#{a}.#{b}.#{c}|]
-instance IsString AppVersion where
-    fromString s = case traverse (readMaybe . toS) $ split (=='.') (toS s) of
-        Just [major, minor, patch] -> AppVersion (major, minor, patch)
-        _                          -> panic . toS $ "Invalid App Version: " <> s
-instance ToJSON AppVersion where
-    toJSON av = String . toS $ let (a,b,c) = unAppVersion av in [i|#{a}.#{b}.#{c}|]
-instance FromJSON AppVersion where
-    parseJSON = withText "app version" $ \t ->
-        case splitOn "." t of
-            [a, b, c] ->
-                case traverse (decode . toS) [a, b, c] of
-                    Just [a', b', c'] -> pure $ AppVersion (a', b', c')
-                    _                 -> fail "non word16 versioning"
-            _ -> fail "unknown versioning"
-instance ToTypedContent AppVersion where
-    toTypedContent = toTypedContent . toJSON
-instance ToContent AppVersion where
-    toContent = toContent . toJSON
-
-(\\) :: AppVersion -> AppVersion -> (Word16, Word16, Word16)
-(\\) (AppVersion (a, b, c)) (AppVersion (a1, b1, c1)) = (a `diffy` a1, b `diffy` b1, c `diffy` c1)
-    where
-        d `diffy` d1 = fromIntegral . abs $ (fromIntegral d :: Integer) - (fromIntegral d1 :: Integer)
 
 data AppStatus = Running | Stopped | Restarting | Removing | Dead deriving (Eq, Show)
 instance ToJSON AppStatus where

src/Util/Function.hs

@@ -6,4 +6,18 @@ import           Startlude
 (.*) = (.) . (.)
 
 (.**) :: (b -> c) -> (a0 -> a1 -> a2 -> b) -> a0 -> a1 -> a2 -> c
-(.**) = (.) . (.*)
+(.**) = (.) . (.*)
+
+preimage :: Eq b => (a -> b) -> b -> [a] -> [a]
+preimage f target = filter ((== target) . f)
+
+mapFind :: ([a] -> Maybe a) -> (b -> a) -> [b] -> Maybe b
+mapFind _ _ [] = Nothing
+mapFind finder mapping (b:bs) = let
+        mB = mapFind finder mapping bs
+        mA = finder [mapping b]
+    in case (mB, mA) of
+        (Just b',_)       -> Just b'
+        (Nothing, Just _) -> Just b
+        _                 -> Nothing
+