diff options
Diffstat (limited to '')
| -rw-r--r-- | server/Server.hs | 111 |
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 |