summaryrefslogtreecommitdiff
path: root/server/Server.hs
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--server/Server.hs111
1 files changed, 61 insertions, 50 deletions
diff --git a/server/Server.hs b/server/Server.hs
index 97f87ee..779509d 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -22,39 +22,40 @@
module Server ( loadConfig
, Org(..)
- , Sha1
+ , Sha1, toSha
, Config, tmpdir, port, verbose, orgs, interval, exneuland, token
, RemoteRef(..)
, ServerState, emptyState, unState
, JobStatus(..)
, setJobStatus
- , prettySha,getJobStatus,adjustedPath) where
+ , prettySha,getJobStatus,adjustedPath,RealtimeMsg(..),newRealtimeChannel) where
import Universum
-import CheckDir (DirResult)
-import CheckMap (ResultKind (Shrunk))
-import Control.Arrow ((>>>))
-import Control.Concurrent (modifyMVar_, withMVar)
-import Crypto.Hash.SHA1 (hash)
-import Data.Aeson (FromJSON, ToJSON, ToJSONKey (..),
- eitherDecodeFileStrict')
-import qualified Data.Aeson as A
-import qualified Data.ByteString.Base64.URL as Base64
-import Data.Coerce (coerce)
-import Data.Either.Extra (mapLeft)
-import Data.Functor.Contravariant (contramap)
-import qualified Data.Map.Strict as M
-import Lens.Micro.Platform (at, ix, makeLenses, traverseOf)
-import LintConfig (LintConfig')
-import Servant (FromHttpApiData)
-import Servant.Client (BaseUrl, parseBaseUrl)
-import qualified Text.Show as TS
-import Toml (BiMap (BiMap), TomlBiMap,
- TomlBiMapError (ArbitraryError),
- TomlCodec, prettyTomlDecodeErrors,
- (.=))
-import qualified Toml as T
+import CheckDir (DirResult)
+import CheckMap (ResultKind (Shrunk))
+import Control.Arrow ((>>>))
+import Control.Concurrent (modifyMVar_, withMVar)
+import Control.Concurrent.STM.TChan (TChan, newBroadcastTChan)
+import Crypto.Hash.SHA1 (hash)
+import Data.Aeson (FromJSON, ToJSON, ToJSONKey (..),
+ eitherDecodeFileStrict')
+import qualified Data.Aeson as A
+import qualified Data.ByteString.Base64.URL as Base64
+import Data.Coerce (coerce)
+import Data.Either.Extra (mapLeft)
+import Data.Functor.Contravariant (contramap)
+import qualified Data.Map.Strict as M
+import Lens.Micro.Platform (at, ix, makeLenses, traverseOf)
+import LintConfig (LintConfig')
+import Servant (FromHttpApiData)
+import Servant.Client (BaseUrl, parseBaseUrl)
+import qualified Text.Show as TS
+import Toml (BiMap (BiMap), TomlBiMap,
+ TomlBiMapError (ArbitraryError),
+ TomlCodec,
+ prettyTomlDecodeErrors, (.=))
+import qualified Toml as T
-- | a reference in a remote git repository
data RemoteRef = RemoteRef
@@ -165,16 +166,39 @@ configCodec = Config
<*> coerce (T.first T.text "token") .= _token
<*> T.list orgCodec "org" .= _orgs
+-- | loads a config, along with all things linked in it
+-- (e.g. linterconfigs for each org)
+loadConfig :: FilePath -> IO (Config True)
+loadConfig path = do
+ res <- T.decodeFileEither configCodec path
+ case res of
+ Right config -> traverseOf orgs (mapM loadOrg) config
+ Left err -> error $ prettyTomlDecodeErrors err
+ where
+ loadOrg :: Org False -> IO (Org True)
+ loadOrg org = do
+ lintconfig <- eitherDecodeFileStrict' (orgLintconfig org) >>= \case
+ Right c -> pure c
+ Left err -> error $ show err
+ pure $ org { orgLintconfig = lintconfig }
+
+data RealtimeMsg = RelintPending | Reload
+ deriving (Generic, ToJSON)
+
+type RealtimeChannel = TChan RealtimeMsg
+
-- | a job status (of a specific uuid)
-data JobStatus =
- Pending | Linted !(DirResult Shrunk) Text | Failed Text
- deriving (Generic, ToJSON, NFData)
+data JobStatus
+ = Pending RealtimeChannel
+ | Linted !(DirResult Shrunk) Text (Bool, RealtimeChannel)
+ | Failed Text
+ -- deriving (Generic, ToJSON, NFData)
instance TS.Show JobStatus where
show = \case
- Pending -> "Pending"
- Linted res rev -> "Linted result"
- Failed err -> "Failed with: " <> show err
+ Pending _ -> "Pending"
+ Linted res rev _ -> "Linted result"
+ Failed err -> "Failed with: " <> show err
-- | the server's global state; might eventually end up with more
-- stuff in here, hence the newtype
@@ -182,7 +206,7 @@ newtype ServerState = ServerState
{ _unState :: Map Text (Org True, Map Sha1 (RemoteRef, JobStatus)) }
deriving Generic
-instance NFData LintConfig' => NFData ServerState
+-- instance NFData LintConfig' => NFData ServerState
makeLenses ''ServerState
@@ -192,23 +216,6 @@ emptyState :: Config True -> ServerState
emptyState config = ServerState
$ M.fromList $ map (\org -> (orgSlug org, (org, mempty))) (view orgs config)
--- | loads a config, along with all things linked in it
--- (e.g. linterconfigs for each org)
-loadConfig :: FilePath -> IO (Config True)
-loadConfig path = do
- res <- T.decodeFileEither configCodec path
- case res of
- Right config -> traverseOf orgs (mapM loadOrg) config
- Left err -> error $ prettyTomlDecodeErrors err
- where
- loadOrg :: Org False -> IO (Org True)
- loadOrg org = do
- lintconfig <- eitherDecodeFileStrict' (orgLintconfig org) >>= \case
- Right c -> pure c
- Left err -> error $ show err
- pure $ org { orgLintconfig = lintconfig }
-
-
-- | NOTE: this does not create the org if it does not yet exist!
setJobStatus :: MVar ServerState -> Org True -> RemoteRef -> JobStatus -> IO ()
setJobStatus mvar !org !ref !status = do
@@ -216,7 +223,7 @@ setJobStatus mvar !org !ref !status = do
-- will otherwise cause a thunk leak, since Data.Map is annoyingly un-strict
-- even in its strict variety. for some reason it also doesn't work when
-- moved inside the `over` though …
- _ <- evaluateNF (view (unState . ix (orgSlug org) . _2) state)
+ _ <- evaluateWHNF (view (unState . ix (orgSlug org) . _2) state)
pure $ over (unState . ix (orgSlug org) . _2 . at (toSha ref))
(const $ Just (ref, status)) state
@@ -234,3 +241,7 @@ getJobStatus mvar orgslug sha = withMVar mvar $ \state -> pure $ do
adjustedPath :: Text -> Org True -> Text -- TODO: filepath library using Text?
adjustedPath rev Org {..} =
orgWebdir <> "/" <> (rev <> show orgGeneration)
+
+
+newRealtimeChannel :: IO RealtimeChannel
+newRealtimeChannel = atomically newBroadcastTChan