diff options
Diffstat (limited to 'server/Server.hs')
| -rw-r--r-- | server/Server.hs | 21 |
1 files changed, 17 insertions, 4 deletions
diff --git a/server/Server.hs b/server/Server.hs index 8f09ac7..f89dc7b 100644 --- a/server/Server.hs +++ b/server/Server.hs @@ -39,11 +39,12 @@ 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 as M +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, @@ -157,9 +158,15 @@ configCodec = Config -- | a job status (of a specific uuid) data JobStatus = - Pending | Linted DirResult Text | Failed Text + Pending | Linted !DirResult Text | Failed Text deriving (Generic, ToJSON) +instance TS.Show JobStatus where + show = \case + 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 newtype ServerState = ServerState @@ -192,8 +199,14 @@ loadConfig path = do -- | 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 = modifyMVar_ mvar - $ pure . over (unState . ix org . at (toSha ref)) (const $ Just (ref, status)) +setJobStatus mvar !org !ref !status = do + modifyMVar_ mvar $ \state -> 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 … + _ <- evaluateWHNF (view (unState . ix org) state) + pure $ over (unState . ix org . at (toSha ref)) + (const $ Just (ref, status)) state getJobStatus :: MVar ServerState -> Text -> Sha1 -> IO (Maybe (RemoteRef, JobStatus)) getJobStatus mvar orgslug sha = withMVar mvar $ \state -> |