initial commit

src/Lib/Error.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE RecordWildCards #-}
+module Lib.Error where
+
+import           Startlude
+
+import           Network.HTTP.Types
+import           Yesod.Core
+
+type S9ErrT m = ExceptT S9Error m
+
+data S9Error = PersistentE Text deriving (Show, Eq)
+
+instance Exception S9Error
+
+-- | Redact any sensitive data in this function
+toError :: S9Error -> Error
+toError = \case
+    PersistentE t -> Error DATABASE_ERROR t
+
+data ErrorCode =
+      DATABASE_ERROR
+    deriving (Eq, Show)
+instance ToJSON ErrorCode where
+    toJSON = String . show
+
+data Error = Error
+    { errorCode    :: ErrorCode
+    , errorMessage :: Text
+    } deriving (Eq, Show)
+instance ToJSON Error where
+    toJSON Error{..} = object
+        [ "code" .= errorCode
+        , "message" .= errorMessage
+        ]
+instance ToContent Error where
+    toContent = toContent . toJSON
+instance ToTypedContent Error where
+    toTypedContent = toTypedContent . toJSON
+
+instance ToTypedContent S9Error where
+    toTypedContent = toTypedContent . toJSON . toError
+instance ToContent S9Error where
+    toContent = toContent . toJSON . toError
+
+toStatus :: S9Error -> Status
+toStatus = \case
+    PersistentE _ -> status500
+
+respondStatusException :: MonadHandler m => S9ErrT m a -> m a
+respondStatusException action = runExceptT action >>= \case
+    Left e -> toStatus >>= sendResponseStatus $ e
+    Right a -> pure a
+
+handleS9ErrNuclear :: MonadIO m => S9ErrT m a -> m a
+handleS9ErrNuclear action = runExceptT action >>= \case
+    Left e -> throwIO e
+    Right a -> pure a

src/Lib/Ssl.hs

@@ -0,0 +1,61 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Lib.Ssl where
+
+import           Startlude
+
+import           Data.String.Interpolate.IsString
+import           System.Directory
+import           System.FilePath
+import           System.Process
+
+import           Constants
+
+-- openssl genrsa -out key.pem 2048
+-- openssl req -new -key key.pem -out certificate.csr
+-- openssl x509 -req -in certificate.csr -signkey key.pem -out certificate.pem
+
+sslBaseLocation :: FilePath
+sslBaseLocation = configBasePath </> "ssl"
+
+sslKeyLocation :: FilePath
+sslKeyLocation = sslBaseLocation </> "key.pem"
+
+sslCsrLocation :: FilePath
+sslCsrLocation = sslBaseLocation </> "certificate.csr"
+
+sslCertLocation :: FilePath
+sslCertLocation = sslBaseLocation </> "certificate.pem"
+
+checkForSslCert :: IO Bool
+checkForSslCert =
+    doesPathExist sslKeyLocation <&&> doesPathExist sslCertLocation
+
+generateSslKey :: IO ExitCode
+generateSslKey = rawSystem "openssl" ["genrsa", "-out", sslKeyLocation, "2048"]
+
+generateSslCert :: Text -> IO ExitCode
+generateSslCert name = rawSystem
+    "openssl"
+    ["req", "-new", "-key", sslKeyLocation, "-out", sslCsrLocation, "-subj", [i|/CN=#{name}.local|]]
+
+selfSignSslCert :: IO ExitCode
+selfSignSslCert = rawSystem
+    "openssl"
+    [ "x509"
+    , "-req"
+    , "-in"
+    , sslCsrLocation
+    , "-signkey"
+    , sslKeyLocation
+    , "-out"
+    , sslCertLocation
+    ]
+
+setupSsl :: IO ()
+setupSsl = do
+    exists <- checkForSslCert
+    unless exists $ do
+        void $ system $ "mkdir -p " <> sslBaseLocation
+        void generateSslKey
+        void $ generateSslCert getRegistryHostname
+        void selfSignSslCert

src/Lib/SystemCtl.hs

@@ -0,0 +1,21 @@
+module Lib.SystemCtl where
+
+import           Startlude      hiding (words)
+import           Unsafe
+
+import           Data.Char
+import           Data.String
+import           System.Process
+import           Text.Casing
+
+data ServiceAction =
+      StartService
+    | StopService
+    | RestartService
+    deriving (Eq, Show)
+
+toAction :: ServiceAction -> String
+toAction = fmap toLower . unsafeHead . words . wordify . show
+
+systemCtl :: ServiceAction -> Text -> IO ExitCode
+systemCtl action service = rawSystem "systemctl" [toAction action, toS service]

src/Lib/Types/Api.hs

@@ -0,0 +1,28 @@
+{-# 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/ServerApp.hs

@@ -0,0 +1,137 @@
+{-# LANGUAGE QuasiQuotes     #-}
+{-# LANGUAGE RecordWildCards #-}
+module Lib.Types.ServerApp where
+
+import           Startlude               hiding (break)
+
+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
+
+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 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
+    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)