Skip to content
Snippets Groups Projects

Compare revisions

Changes are shown as if the source revision was being merged into the target revision. Learn more about comparing revisions.

Source

Select target project
No results found
Select Git revision

Target

Select target project
No results found
Select Git revision
Show changes
Expand all Hide whitespace changes
Inline Side-by-side
Showing
with 3528 additions and 220 deletions
lib/Types.hs
View file @ d3dcb5f4
......@@ -7,21 +7,27 @@
-- | basic types for the linter to eat and produce
-- The dark magic making thse useful is in LintWriter
module Types where
module Types
( Level(..)
, Lint(..)
, Dep(..)
, Hint(..)
, hint
, lintLevel
, lintsToHints
) where
import Universum
import Control.Monad.Trans.Maybe ()
import Data.Aeson (FromJSON, ToJSON (toJSON),
ToJSONKey, (.=))
import Data.Text (Text)
import GHC.Generics (Generic)
import Badges (Badge)
import qualified Data.Aeson as A
import Data.Maybe (mapMaybe)
import Paths (RelPath)
import Util (PrettyPrint (..), showText)
import WithCli (Argument, Proxy (..),
atomicArgumentsParser)
import Util (PrettyPrint (..))
import WithCli (Argument, atomicArgumentsParser)
import WithCli.Pure (Argument (argumentType, parseArgument),
HasArguments (argumentsParser))
......@@ -29,7 +35,7 @@ import WithCli.Pure (Argument (argumentType, parseArgumen
-- | Levels of errors and warnings, collectively called
-- "Hints" until I can think of some better name
data Level = Info | Suggestion | Warning | Forbidden | Error | Fatal
deriving (Show, Generic, Ord, Eq, ToJSON, FromJSON)
deriving (Show, Generic, Ord, Eq, ToJSON, FromJSON, NFData)
instance Argument Level where
argumentType Proxy = "Lint Level"
......@@ -48,16 +54,16 @@ instance HasArguments Level where
-- | a hint comes with an explanation (and a level), or is a dependency
-- (in which case it'll be otherwise treated as an info hint)
data Lint = Depends Dep | Offers Text | Lint Hint | Badge Badge
data Lint = Depends Dep | Offers Text | Lint Hint | Badge Badge | CW [Text]
deriving (Ord, Eq, Generic, ToJSONKey)
data Dep = Local RelPath | Link Text | MapLink Text | LocalMap RelPath
deriving (Generic, Ord, Eq)
deriving (Generic, Ord, Eq, NFData)
data Hint = Hint
{ hintLevel :: Level
, hintMsg :: Text
} deriving (Generic, Ord, Eq)
} deriving (Generic, Ord, Eq, NFData)
-- | shorter constructor (called hint because (a) older name and
-- (b) lint also exists and is monadic)
......@@ -74,16 +80,18 @@ lintsToHints = mapMaybe (\case {Lint hint -> Just hint ; _ -> Nothing})
instance PrettyPrint Lint where
prettyprint (Lint Hint { hintMsg, hintLevel } ) =
" " <> showText hintLevel <> ": " <> hintMsg
" " <> show hintLevel <> ": " <> hintMsg
prettyprint (Depends dep) =
" Info: found dependency: " <> prettyprint dep
prettyprint (Offers dep) =
" Info: map offers entrypoint " <> prettyprint dep
prettyprint (Badge _) =
" Info: found a badge."
prettyprint (CW cws) =
" CWs: " <> show cws
instance PrettyPrint Hint where
prettyprint (Hint level msg) = " " <> showText level <> ": " <> msg
prettyprint (Hint level msg) = " " <> show level <> ": " <> msg
instance ToJSON Lint where
toJSON (Lint h) = toJSON h
......@@ -96,6 +104,9 @@ instance ToJSON Lint where
toJSON (Badge _) = A.object
[ "msg" .= A.String "found a badge"
, "level" .= A.String "Badge Info"]
toJSON (CW cws) = A.object
[ "msg" .= A.String "Content Warning"
, "level" .= A.String "CW Info" ]
instance ToJSON Hint where
toJSON (Hint l m) = A.object
......
lib/Uris.hs
View file @ d3dcb5f4
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
-- | Functions to deal with uris and custom uri schemes
module Uris where
import Universum
import Control.Monad (unless, when)
import Data.Aeson (FromJSON (..), Options (..),
SumEncoding (UntaggedValue),
defaultOptions, genericParseJSON)
import Data.Data (Proxy)
import Data.Either.Combinators (maybeToRight, rightToMaybe)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Text (Text, pack)
import qualified Data.Text as T
import GHC.Generics (Generic)
import GHC.TypeLits (KnownSymbol, symbolVal)
import Network.URI.Encode as URI
import Text.Regex.TDFA ((=~))
import Witherable (mapMaybe)
import Data.Aeson (FromJSON (..), Options (..),
SumEncoding (UntaggedValue),
defaultOptions, genericParseJSON)
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import GHC.TypeLits (KnownSymbol, symbolVal)
import Network.URI (URI (..), URIAuth (..), parseURI,
uriToString)
import qualified Network.URI.Encode as URI
data Substitution =
Prefixed { prefix :: Text, blocked :: [Text], allowed :: [Text], scope :: [String] }
| DomainSubstitution { substs :: Map Text Text, scope :: [String] }
| Allowed { scope :: [String], allowed :: [Text] }
deriving (Generic, Show)
| Unrestricted { scope :: [String] }
deriving (Generic, Show, NFData)
instance FromJSON Substitution where
......@@ -39,22 +35,24 @@ instance FromJSON Substitution where
, rejectUnknownFields = True
}
type SchemaSet = [(Text, Substitution)]
type SchemaSet = Map Text [Substitution]
extractDomain :: Text -> Maybe Text
extractDomain url =
let (_,_,_,matches) = url =~ "^https://([^/]+)/?.*$" :: (Text,Text,Text,[Text])
in case matches of
[domain] -> Just domain
_ -> Nothing
-- | deconstruct a URI into a triple of [schema:]//[domain]/[tail...],
-- and a normalised version of the same URI
parseUri :: Text -> Maybe (Text, Text, Text, Text)
parseUri raw =
case parseURI (toString (T.strip raw)) of
Nothing -> Nothing
Just uri@URI{..} -> case uriAuthority of
Nothing -> Nothing
Just URIAuth {..} -> Just
( fromString uriScheme
, fromString $ uriUserInfo <> uriRegName <> uriPort
, fromString $ uriPath <> uriQuery <> uriFragment
, fromString $ uriToString id uri ""
)
parseUri :: Text -> Maybe (Text, Text, Text)
parseUri uri =
let (_,_,_,matches) = uri =~ "^([a-zA-Z0-9]+)://([^/]+)(/?.*)$" :: (Text,Text,Text,[Text])
in case matches of
[schema, domain, rest] -> Just (schema, domain, rest)
_ -> Nothing
data SubstError =
SchemaDoesNotExist Text
......@@ -63,43 +61,46 @@ data SubstError =
| IsBlocked
| DomainIsBlocked [Text]
| VarsDisallowed
| WrongScope Text [Text]
-- ^ This link's schema exists, but cannot be used in this scope.
-- The second field contains a list of schemas that may be used instead.
| WrongScope Text [Text]
deriving (Eq, Ord) -- errors are ordered so we can show more specific ones
applySubsts :: KnownSymbol s
=> Proxy s -> SchemaSet -> Text -> Either SubstError Text
applySubsts s substs uri = do
when (T.isInfixOf (pack "{{") uri || T.isInfixOf (pack "}}") uri)
when (T.isInfixOf "{{" uri || T.isInfixOf "}}" uri)
$ Left VarsDisallowed
parts@(schema, _, _) <- note NotALink $ parseUri uri
parts@(schema, _, _, _) <- maybeToRight NotALink $ parseUri uri
let rules = filter ((==) schema . fst) substs
case fmap (applySubst parts . snd) rules of
[] -> Left (SchemaDoesNotExist schema)
results@(_:_) -> case mapMaybe rightToMaybe results of
suc:_ -> Right suc
_ -> minimum results
let rules = filter (elem thisScope . scope) . concat $ M.lookup schema substs
case nonEmpty $ map (applySubst parts) rules of
Nothing -> Left (SchemaDoesNotExist schema)
Just result -> minimum result
where
note = maybeToRight
applySubst (schema, domain, rest) rule = do
thisScope = symbolVal s
applySubst (schema, domain, rest, uri) rule = do
-- is this scope applicable?
unless (symbolVal s `elem` scope rule)
$ Left (WrongScope schema
(fmap fst . filter (elem (symbolVal s) . scope . snd) $ substs))
$ map fst -- make list of available uri schemes
. filter (any (elem thisScope . scope) . snd)
$ toPairs substs)
case rule of
DomainSubstitution table _ -> do
prefix <- note (DomainDoesNotExist (schema <> pack "://" <> domain))
$ M.lookup domain table
prefix <- case M.lookup domain table of
Nothing -> Left (DomainDoesNotExist (schema <> "//" <> domain))
Just a -> Right a
pure (prefix <> rest)
Prefixed {..}
| domain `elem` blocked -> Left IsBlocked
| domain `elem` allowed || pack "streamproxy.rc3.world" `T.isSuffixOf` domain -> Right uri
| domain `elem` allowed -> Right uri
| otherwise -> Right (prefix <> URI.encodeText uri)
Allowed _ domains -> if domain `elem` domains
|| pack "streamproxy.rc3.world" `T.isSuffixOf` domain
then Right uri
else Left (DomainIsBlocked domains)
Allowed _ allowlist
| domain `elem` allowlist -> Right uri
| otherwise -> Left (DomainIsBlocked allowlist)
Unrestricted _ -> Right uri
lib/Util.hs
View file @ d3dcb5f4
......@@ -2,28 +2,26 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
-- | has (perhaps inevitably) morphed into a module that mostly
-- concerns itself with wrangling haskell's string types
module Util where
module Util
( mkProxy
, PrettyPrint(..)
, printPretty
, naiveEscapeHTML
, ellipsis
) where
import Universum
import Data.Aeson as Aeson
import Data.Proxy (Proxy (..))
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Tiled (Layer (layerData), PropertyValue (..),
import Data.Tiled (Layer (layerData), PropertyValue (..),
Tileset (tilesetName), layerName, mkTiledId)
-- | helper function to create proxies
mkProxy :: a -> Proxy a
mkProxy = const Proxy
-- | haskell's many string types are FUN …
showText :: Show a => a -> Text
showText = T.pack . show
-- | a class to address all the string conversions necessary
-- when using Show to much that just uses Text instead
class PrettyPrint a where
......@@ -37,7 +35,7 @@ instance PrettyPrint Text where
instance PrettyPrint Aeson.Value where
prettyprint = \case
Aeson.String s -> prettyprint s
v -> (T.pack . show) v
v -> show v
instance PrettyPrint t => PrettyPrint (Set t) where
prettyprint = prettyprint . S.toList
......@@ -46,8 +44,8 @@ instance PrettyPrint PropertyValue where
prettyprint = \case
StrProp str -> str
BoolProp bool -> if bool then "true" else "false"
IntProp int -> showText int
FloatProp float -> showText float
IntProp int -> show int
FloatProp float -> show float
-- | here since Unit is sometimes used as dummy type
instance PrettyPrint () where
......@@ -63,13 +61,13 @@ instance PrettyPrint a => PrettyPrint [a] where
prettyprint = T.intercalate ", " . fmap prettyprint
printPretty :: PrettyPrint a => a -> IO ()
printPretty = putStr . T.unpack . prettyprint
printPretty = putStr . toString . prettyprint
-- | for long lists which shouldn't be printed out in their entirety
ellipsis :: Int -> [Text] -> Text
ellipsis i texts
| i < l = prettyprint (take i texts) <> " ... (and " <> showText (l-i) <> " more)"
| i < l = prettyprint (take i texts) <> " ... (and " <> show (l-i) <> " more)"
| otherwise = prettyprint texts
where l = length texts
......
lib/WriteRepo.hs
View file @ d3dcb5f4
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Module for writing an already linted map Repository back out again.
module WriteRepo where
module WriteRepo (writeAdjustedRepository) where
import Universum
import CheckDir (DirResult (..), resultIsFatal)
import CheckMap (MapResult (..))
import Control.Monad (forM_, unless)
import Control.Monad.Extra (ifM)
import CheckMap (MapResult (..), ResultKind (..))
import Data.Aeson (encodeFile)
import Data.Map.Strict (toList)
import Data.Maybe (mapMaybe)
import Data.Set (Set)
import qualified Data.Set as S
import LintConfig (LintConfig (configDontCopyAssets),
LintConfig')
......@@ -26,8 +24,8 @@ import System.FilePath.Posix ((</>))
import Types (Dep (Local))
writeAdjustedRepository :: LintConfig' -> FilePath -> FilePath -> DirResult -> IO ExitCode
-- TODO: make this return a custom error type, not an exitcode
writeAdjustedRepository :: LintConfig' -> FilePath -> FilePath -> DirResult Full -> IO ExitCode
writeAdjustedRepository config inPath outPath result
| resultIsFatal config result =
pure (ExitFailure 1)
......@@ -36,7 +34,7 @@ writeAdjustedRepository config inPath outPath result
createDirectoryIfMissing True outPath
-- write out all maps
forM_ (toList $ dirresultMaps result) $ \(path,out) -> do
forM_ (toPairs $ dirresultMaps result) $ \(path,out) -> do
createDirectoryIfMissing True (takeDirectory (outPath </> path))
encodeFile (outPath </> path) $ mapresultAdjusted out
......@@ -51,7 +49,7 @@ writeAdjustedRepository config inPath outPath result
Local path -> Just . normalise mapdir $ path
_ -> Nothing)
$ mapresultDepends mapresult)
. toList $ dirresultMaps result
. toPairs $ dirresultMaps result
-- copy all assets
forM_ localdeps $ \path ->
......
nix/sources.json
View file @ d3dcb5f4
{
"haskellNix": {
"branch": "master",
"description": "Alternative Haskell Infrastructure for Nixpkgs",
"homepage": "https://input-output-hk.github.io/haskell.nix",
"owner": "input-output-hk",
"repo": "haskell.nix",
"rev": "659b73698e06c02cc0f3029383bd383c8acdbe98",
"sha256": "0i91iwa11sq0v82v0zl82npnb4qqfm71y7gn3giyaixslm73kspk",
"type": "tarball",
"url": "https://github.com/input-output-hk/haskell.nix/archive/659b73698e06c02cc0f3029383bd383c8acdbe98.tar.gz",
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
},
"niv": {
"branch": "master",
"description": "Easy dependency management for Nix projects",
......
package.yaml 0 → 100644
View file @ d3dcb5f4
name: walint
version: 0.1
homepage: https://stuebinm.eu/git/walint
# TODO: license
author: stuebinm
maintainer: stuebinm@disroot.org
copyright: 2022 stuebinm
ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors
default-extensions: NoImplicitPrelude
dependencies:
- base
- universum
- aeson
- bytestring
- text
internal-libraries:
tiled:
source-dirs: 'tiled'
dependencies:
- vector
exposed-modules:
- Data.Tiled
- Data.Tiled.Abstract
library:
source-dirs: 'lib'
dependencies:
- containers
- tiled
- text
- vector
- transformers
- either
- filepath
- getopt-generics
- regex-tdfa
- extra
- deepseq
- dotgen
- text-metrics
- uri-encode
- network-uri
exposed-modules:
- CheckDir
- CheckMap
- WriteRepo
- Util
- Types
- LintConfig
executables:
walint:
main: Main.hs
source-dirs: 'src'
dependencies:
- walint
- getopt-generics
- aeson-pretty
- template-haskell
- process
cwality-maps:
main: Main.hs
source-dirs: 'cwality-maps'
ghc-options: -rtsopts -threaded
dependencies:
- tiled
- servant
- servant-server
- wai
- wai-extra
- warp
- monad-logger
- fmt
- tomland
- microlens-platform
- directory
- filepath
- containers
- base64
- parsec
- mustache
walint-mapserver:
main: Main.hs
source-dirs: 'server'
ghc-options: -rtsopts -threaded
dependencies:
- walint
- containers
- base-compat
- time
- directory
- filepath
- warp
- wai
- wai-extra
- monad-logger
- lucid
- servant
- servant-server
- servant-client
- servant-lucid
- servant-websockets
- http-types
- http-client
- websockets
- process
- extra
- microlens-platform
- fmt
- tomland
- stm
- getopt-generics
- async
- cryptohash-sha1
- uuid
- base64-bytestring
server/Handlers.hs 0 → 100644
View file @ d3dcb5f4
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Handlers (
-- , submitImpl
statusImpl
-- , relintImpl
, stateImpl
, AdminOverview(..)
, MapService(..),relintImpl,realtimeImpl) where
import Universum
import CheckDir (DirResult (dirresultMaps))
import CheckMap (MapResult (MapResult, mapresultBadges))
import Control.Concurrent.STM (TQueue, dupTChan, readTChan,
writeTQueue)
import Data.Aeson (ToJSON (..), (.=))
import qualified Data.Aeson as A
import qualified Data.Aeson.Key as A
import Data.Coerce (coerce)
import qualified Data.Map as M
import Network.WebSockets (PendingConnection, acceptRequest,
rejectRequest, sendTextData,
withPingThread)
import Servant (Handler, err404, throwError)
import Server (JobStatus (..), Org (orgUrl),
RemoteRef (reponame), ServerState,
Sha1, getJobStatus,
unState, adjustedWebPath)
import Worker (Job (Job))
-- | an info type wrapped around the server state, to carry serialisation instances.
newtype AdminOverview =
AdminOverview { unAdminOverview :: ServerState }
newtype MapService =
MapService { unMapService :: ServerState }
instance ToJSON MapService where
toJSON (MapService state) =
toJSON . map orgObject $ view unState state
where
orgObject (org, statuses) =
A.object
. mapMaybe worldObject
$ M.elems statuses
where
worldObject (remote, _current, result) = case result of
Just (Linted res rev _) ->
Just (A.fromText (reponame remote) .=
M.mapWithKey (mapInfo rev) (dirresultMaps res))
_ -> Nothing
mapInfo rev mappath MapResult { .. } = A.object
[ "badges" .= mapresultBadges
-- TODO: type-safe url library for adding the slash?
, "url" .= (orgUrl org <> adjustedWebPath rev org <> "/" <> toText mappath) ]
statusImpl :: MVar ServerState -> Text -> Sha1 -> Handler (Org True, RemoteRef, JobStatus, Maybe JobStatus)
statusImpl state orgslug sha1 = do
status <- liftIO $ getJobStatus state orgslug sha1
case status of
Just stuff -> pure stuff
Nothing -> throwError err404
-- | since there are multiple apis that just get state information …
stateImpl
:: forall s
. Coercible s ServerState
=> MVar ServerState
-> Handler s
stateImpl state = readMVar state <&> coerce
relintImpl :: TQueue Job -> MVar ServerState -> Text -> Sha1 -> Handler Text
relintImpl queue state orgslug sha1 =
liftIO $ getJobStatus state orgslug sha1 >>= \case
Nothing -> pure "there isn't a job here to restart"
Just (org, ref, _oldjob, _veryoldjob) -> do
atomically $ writeTQueue queue (Job ref org)
pure "hello"
realtimeImpl :: MVar ServerState -> Text -> Sha1 -> PendingConnection -> Handler ()
realtimeImpl state orgslug sha1 pending =
liftIO (getJobStatus state orgslug sha1) >>= \case
Just (_org, _ref, Linted _ _ (_, realtime), _) -> do
conn <- liftIO $ acceptRequest pending
incoming <- atomically $ dupTChan realtime
liftIO $ withPingThread conn 30 pass $ forever $ do
next <- atomically $ readTChan incoming
sendTextData conn (A.encode next)
_ -> liftIO $ rejectRequest pending "no!"
server/HtmlOrphans.hs 0 → 100644
View file @ d3dcb5f4
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-- the ToHtml class also provides a method without escaping which we don't use,
-- so it's safe to never define it
{-# OPTIONS_GHC -Wno-missing-methods #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
-- | Module containing orphan instances of Lucid's ToHtml, used for rendering
-- linter results as html
module HtmlOrphans () where
import Universum
import CheckDir (DirResult (..), MissingAsset (MissingAsset),
MissingDep (..), maximumLintLevel)
import CheckMap (MapResult (..))
import Data.List.Extra (escapeJSON)
import qualified Data.Map as M
import qualified Data.Text as T
import Handlers (AdminOverview (..))
import Lucid (HtmlT, ToHtml)
import Lucid.Base (ToHtml (toHtml))
import Lucid.Html5 (a_, body_, button_, class_, code_, disabled_,
div_, em_, h1_, h2_, h3_, h4_, h5_, head_,
href_, html_, id_, li_, link_, main_,
onclick_, p_, rel_, script_, span_, src_,
title_, type_, ul_)
import Server (JobStatus (..),
Org (Org, orgBacklinkPrefix, orgContactMail, orgHowtoLink, orgSlug),
RemoteRef (RemoteRef, reponame, reporef, repourl),
prettySha, unState)
import Types (Hint (Hint), Level (..))
import Fmt
mono :: Monad m => HtmlT m () -> HtmlT m ()
mono = code_ [class_ "small text-muted"]
htmldoc :: Monad m => HtmlT m () -> HtmlT m ()
htmldoc inner = html_ $ do
head_ $ do
title_ "Job Status"
link_ [rel_ "stylesheet", type_ "text/css", href_ "/bootstrap.min.css" ]
link_ [rel_ "stylesheet", type_ "text/css", href_ "/style.css" ]
body_ $ main_ [class_ "main-content"] inner
instance ToHtml (Org True, RemoteRef, JobStatus, Maybe JobStatus) where
toHtml (org@Org{..}, ref@RemoteRef{..}, status, published) = htmldoc $ case status of
Pending _ -> do
h1_ "Pending …"
autoReloadScript
Linted res rev (pending, _) -> do
h1_ $ do
"Linter Result"
if pending
then button_ [class_ "btn btn-primary btn-disabled", disabled_ "true"] "pending …"
else button_ [onclick_ "relint()", class_ "btn btn-primary", id_ "relint_button"] "Relint"
whenJust orgHowtoLink $ \link ->
a_ [class_ "btn btn-primary", href_ link] "Howto"
a_ [class_ "btn btn-primary"
, href_ ("mailto:" <> orgContactMail <> "?subject=[Help-walint] " <> reponame <> " " <> rev)]
"Help?"
p_ $ do
"For commit "; code_ (toHtml $ T.take 7 rev); " of repository "
code_ (toHtml repourl); " (on "; code_ (toHtml reporef); ")"
p_ $ case published of
Just (Linted _ rev _) ->
do "Currently published commit: "; code_ (toHtml $ T.take 7 rev); "."
_ -> "This Map has not yet been published."
toHtml (org,ref,res)
script_
"function relint() {\n\
\ var xhr = new XMLHttpRequest ();\n\
\ xhr.open('POST', 'relint', true);\n\
\ xhr.onreadystatechange = (e) => {if (xhr.status == 200) {\n\
\ console.log(e);\n\
\ }}\n\
\ xhr.send(null);\n\
\}"
autoReloadScript
Failed err -> do
h1_ "System Error"
p_ $ "error: " <> toHtml err
p_ "you should probably ping an admin about this or sth"
where
autoReloadScript = script_
"let proto = window.location.protocol === 'https://' ? 'wss' : 'ws://';\
\let ws = new WebSocket(proto + window.location.host + window.location.pathname + 'realtime');\n\
\ws.onmessage = (event) => {\n\
\ let resp = JSON.parse(event.data);\n\
\ if (resp == 'RelintPending') {\n\
\ let btn = document.getElementById('relint_button');\n\
\ btn.innerText = 'pending …';\n\
\ btn.disabled = true;\n\
\ btn.class = 'btn btn-disabled';\n\
\ } else if (resp == 'Reload') {\n\
\ location.reload();\n\
\ }\n\
\}"
instance ToHtml AdminOverview where
toHtml (AdminOverview state) = htmldoc $ do
h1_ "Map List"
forM_ (view unState state) $ \(org, jobs) -> do
h2_ (toHtml $ orgSlug org)
if null jobs then em_ "(nothing yet)"
else flip M.foldMapWithKey jobs $ \sha1 (ref, status, _lastvalid) -> li_ $ do
case status of
Pending _ -> badge Info "pending"
(Linted res rev _) -> toHtml $ maximumLintLevel res
(Failed _) -> badge Error "system error"
" "; a_ [href_ ("/status/"+|orgSlug org|+"/"+|prettySha sha1|+"/")] $ do
mono $ toHtml $ reporef ref; " on "; mono $ toHtml $ repourl ref
badge :: Monad m => Level -> HtmlT m () -> HtmlT m ()
badge level = span_ [class_ badgetype]
where badgetype = case level of
Info -> "badge badge-info"
Suggestion -> "badge badge-info"
Warning -> "badge badge-warning"
Forbidden -> "badge badge-danger"
Error -> "badge badge-danger"
Fatal -> "badge badge-danger"
-- | pseudo-level badge when we don't even have an info lint
-- (rare, but it does happen!)
badgeHurray :: Monad m => HtmlT m() -> HtmlT m ()
badgeHurray = span_ [class_ "badge badge-success"]
-- | Lint Levels directly render into badges
instance ToHtml Level where
toHtml level = do badge level (show level); " "
-- | Hints are just text with a level
instance ToHtml Hint where
toHtml (Hint level msg) = do
toHtml level; " "; toHtml msg
headerText :: Monad m => Level -> HtmlT m ()
headerText = \case
Info ->
"Couldn't find a thing to complain about. Congratulations!"
Suggestion ->
"There's a couple smaller nitpicks; maybe take a look at those? \
\But overall the map looks great!"
Warning ->
"The map is fine, but some things look like they might be mistakes; \
\perhaps you want to take a look at those?"
Forbidden ->
"While this map might work well with workadventure, it contains \
\things that are not allowed at this event. Please change those \
\so we can publish the map"
Error ->
"Your map currently contains errors. You will have to fix those before \
\we can publish your map."
Fatal ->
"Something broke while linting; if you're not sure why or how to make \
\it work, feel free to tell an admin about it."
-- | The fully monky
instance ToHtml (Org True, RemoteRef, DirResult a) where
toHtml (Org {..}, RemoteRef {..}, res@DirResult { .. }) = do
p_ $ do badge maxlevel "Linted:"; " "; headerText maxlevel
h2_ "Exits"
p_ $ do
"Note: to link back to the lobby, please use "
code_ $ toHtml $ orgBacklinkPrefix <> reponame
" as exitUrl."
-- the exit graph thing
script_ [ src_ "/dot-wasm.js" ] (""::Text)
script_ [ src_ "/d3.js" ] (""::Text)
script_ [ src_ "/d3-graphviz.js" ] (""::Text)
div_ [ id_ "exitGraph" ] ""
script_ $
"\
\d3.select(\"#exitGraph\")\n\
\ .graphviz().engine(\"fdp\")\n\
\ .dot(\"" <> toText (escapeJSON $ toString dirresultGraph) <> "\")\n\
\ .render()\n\
\"
unless (null dirresultDeps) $ ul_ $
forM_ dirresultDeps $ \missing -> do
li_ $ do
-- TODO: the whole Maybe Bool thing is annoying; I think that was a
-- remnant of talking to python stuff and can probably be removed?
if depFatal missing == Just True
then do { toHtml Error; "Map " }
else do { toHtml Warning; "Entrypoint " }
code_ $ toHtml (entrypoint missing)
" does not exist"
unless (depFatal missing /= Just True) $ do
" (no layer with that name is a "; mono "startLayer"; ")"
", but is used as "; mono "exitUrl"; " in "
placeList (neededBy missing); "."
unless (null dirresultMissingAssets) $ do
h2_ [class_ "border-bottom"] "Assets"
ul_ $ forM_ dirresultMissingAssets $
\(MissingAsset MissingDep { .. }) -> li_ $ do
toHtml Error; "File "; mono $ toHtml entrypoint
" does not exist, but is referenced in "; placeList neededBy; ")"
unless (null dirresultMaps) $ do
h2_ "Maps"
flip M.foldMapWithKey dirresultMaps $ \name MapResult { .. } -> do
h3_ (toHtml name)
if null mapresultGeneral && null mapresultLayer && null mapresultTileset
then ul_ $ li_ $ badgeHurray "All good!"
else do
ul_ $ forM_ mapresultGeneral $ \lint ->
li_ (toHtml lint)
unless (null mapresultLayer) $ do
h4_ "Layers"
ul_ (listMapWithKey mapresultLayer)
unless (null mapresultTileset) $ do
h4_ "Tilesets"
ul_ (listMapWithKey mapresultTileset)
where
maxlevel = maximumLintLevel res
placeList :: (Monad m, ToHtml a) => [a] -> HtmlT m ()
placeList occurances =
sequence_ . intersperse ", " $ occurances <&> \place ->
code_ [class_ "small text-muted"] (toHtml place)
listMapWithKey map =
flip M.foldMapWithKey map $ \lint places ->
li_ $ do toHtml lint; " (in "; placeList places; ")"
server/Main.hs 0 → 100644
View file @ d3dcb5f4
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-- | simple server offering linting "as a service"
module Main where
import Universum
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (async, link, waitEither_)
import Control.Concurrent.STM.TQueue (TQueue, newTQueueIO,
writeTQueue)
import qualified Data.Text as T
import Fmt ((+|), (|+))
import Handlers (AdminOverview (AdminOverview),
MapService (MapService),
realtimeImpl, relintImpl,
stateImpl, statusImpl)
import HtmlOrphans ()
import Network.HTTP.Client (defaultManagerSettings,
newManager)
import Network.Wai.Handler.Warp (defaultSettings,
runSettings, setPort)
import Network.Wai.Middleware.Gzip (def)
import Network.Wai.Middleware.RequestLogger (OutputFormat (..),
RequestLoggerSettings (..),
mkRequestLogger)
import Servant (Application, Capture,
Get, JSON, PlainText,
Post, Raw, ReqBody,
Server, serve,
type (:<|>) (..),
type (:>))
import Servant.HTML.Lucid (HTML)
import Servant.Server.StaticFiles (serveDirectoryWebApp)
import Server (CliOptions (..),
JobStatus, Org (..),
RemoteRef, ServerState,
Sha1, emptyState,
exneuland, interval,
loadConfig, orgs, port,
token, verbose)
import Worker (Job (Job), linterThread)
import Control.Monad.Logger (logInfoN,
runStdoutLoggingT)
import Servant.API (Header)
import Servant.API.WebSocket (WebSocketPending)
import Servant.Client (ClientM, client,
mkClientEnv, runClientM)
import WithCli (withCli)
type family PolyEndpoint method format payload where
PolyEndpoint Get format payload =
Get format payload
PolyEndpoint Post format payload =
Header "Auth" Text :> ReqBody format payload :> Post '[PlainText] Text
type MapServiceAPI method =
"api" :> "maps" :> "list" :> PolyEndpoint method '[JSON] MapService
-- | abstract api
type API format =
"status" :> Capture "org" Text :> Capture "jobid" Sha1 :> Get '[format] (Org True, RemoteRef, JobStatus, Maybe JobStatus)
:<|> "status" :> Capture "org" Text :> Capture "jobid" Sha1 :> "relint" :> Post '[format] Text
:<|> "status" :> Capture "org" Text :> Capture "jobid" Sha1 :> "realtime" :> WebSocketPending
:<|> "admin" :> "overview" :> Get '[format] AdminOverview
-- | actual set of routes: api for json & html + static pages from disk
type Routes = -- "api" :> API JSON
MapServiceAPI Get
:<|> API HTML -- websites mirror the API exactly
:<|> Raw
-- | API's implementation
jsonAPI :: forall format. TQueue Job -> MVar ServerState -> Server (API format)
jsonAPI queue state = statusImpl state
:<|> relintImpl queue state
:<|> realtimeImpl state
:<|> stateImpl @AdminOverview state
-- | Complete set of routes: API + HTML sites
server :: TQueue Job -> MVar ServerState -> Server Routes
server queue state = -- jsonAPI @JSON queue state
stateImpl @MapService state
:<|> jsonAPI @HTML queue state
:<|> serveDirectoryWebApp "./static"
app :: TQueue Job -> MVar ServerState -> Application
app queue = serve (Proxy @Routes) . server queue
postNewMaps :: Maybe Text -> MapService -> ClientM Text
postNewMaps = client (Proxy @(MapServiceAPI Post))
main :: IO ()
main = withCli $ \CliOptions {..} -> do
config <- loadConfig (fromMaybe "./config.toml" config)
state <- newMVar (emptyState config)
queue :: TQueue Job <- newTQueueIO
loggerMiddleware <- mkRequestLogger
$ def { outputFormat = Detailed (view verbose config) }
putTextLn "reading config …"
putTextLn $ T.concat $ map showInfo (view orgs config)
-- periodically ‘pokes’ jobs to re-lint each repo
poker <- async $ forever $ do
atomically $ forM_ (view orgs config) $ \org ->
forM_ (orgRepos org) $ \repo ->
writeTQueue queue (Job repo org)
-- microseconds for some reason
threadDelay (view interval config * 1000000)
-- TODO: what about tls / https?
unless offline $ whenJust (view exneuland config) $ \baseurl -> do
manager' <- newManager defaultManagerSettings
updater <- async $ runStdoutLoggingT $ forever $ do
done <- readMVar state
res <- liftIO $ runClientM
(postNewMaps (view token config) (MapService done))
(mkClientEnv manager' baseurl)
logInfoN $ "exneuland maps POST request: " <> show res
liftIO $ threadDelay (view interval config * 1000000)
link updater
-- spawns threads for each job in the queue
linter <- async $ void $ linterThread offline config queue state
link linter
link poker
let warpsettings =
setPort (view port config)
defaultSettings
putTextLn $ "starting server on port " <> show (view port config)
runSettings warpsettings
. loggerMiddleware
$ app queue state
waitEither_ linter poker
where
showInfo org =
"→ org "+|orgSlug org|+" ("+|length (orgRepos org)|+" repositories)\n" :: Text
server/Server.hs 0 → 100644
View file @ d3dcb5f4
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Server ( loadConfig
, Org(..)
, Sha1, toSha
, Config, tmpdir, port, verbose, orgs, interval, exneuland, token
, CliOptions(..)
, OfflineException
, RemoteRef(..)
, ServerState, emptyState, unState
, JobStatus(..)
, prettySha,getJobStatus,overJobStatus
, adjustedPath,RealtimeMsg(..),newRealtimeChannel,adjustedWebPath) where
import Universum
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 (ConfigKind (..), LintConfig,
feedConfig)
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 WithCli (HasArguments)
-- | a reference in a remote git repository
data RemoteRef = RemoteRef
{ repourl :: Text
, reporef :: Text
, reponame :: Text
-- ^ the "world name" for the hub / world:// links
} deriving (Generic, FromJSON, ToJSON, Eq, Ord, Show, NFData)
type family ConfigRes (b :: Bool) a where
ConfigRes True a = a
ConfigRes False a = FilePath
-- | the internal text is actually already base64-encoded
newtype Sha1 = Sha1 Text
deriving newtype (Eq, Show, Ord, FromHttpApiData, ToJSON, NFData)
-- | base64-encoded sha1
prettySha :: Sha1 -> Text
prettySha (Sha1 text) = text
instance ToJSONKey Sha1
toSha :: RemoteRef -> Sha1
toSha ref = Sha1
. decodeUtf8
. Base64.encode
. hash
. encodeUtf8
$ (show ref :: Text)
data Org (loaded :: Bool) = Org
{ orgSlug :: Text
, orgLintconfig :: ConfigRes loaded (LintConfig Skeleton)
, orgEntrypoint :: FilePath
, orgGeneration :: Int
, orgRepos :: [RemoteRef]
, orgUrl :: Text
, orgWebdir :: Text
, orgBacklinkPrefix :: Text
, orgContactMail :: Text
, orgHowtoLink :: Maybe Text
} deriving (Generic)
instance NFData (LintConfig Skeleton) => NFData (Org True)
deriving instance Show (LintConfig Skeleton) => Show (Org True)
-- | Orgs are compared via their slugs only
-- TODO: the server should probably refuse to start if two orgs have the
-- same slug … (or really the toml format shouldn't allow that syntactically)
instance Eq (Org True) where
a == b = orgSlug a == orgSlug b
instance Ord (Org True) where
a <= b = orgSlug a <= orgSlug b
-- this instance exists since it's required for ToJSONKey,
-- but it shouldn't really be used
instance ToJSON (Org True) where
toJSON Org { .. } = A.object [ "slug" A..= orgSlug ]
-- orgs used as keys just reduce to their slug
instance ToJSONKey (Org True) where
toJSONKey = contramap orgSlug (toJSONKey @Text)
-- | the server's configuration
data Config (loaded :: Bool) = Config
{ _tmpdir :: FilePath
-- ^ dir to clone git things in
, _port :: Int
, _verbose :: Bool
, _interval :: Int
-- ^ port to bind to
, _exneuland :: Maybe BaseUrl
, _token :: Maybe Text
, _orgs :: [Org loaded]
} deriving Generic
makeLenses ''Config
data CliOptions = CliOptions
{ offline :: Bool
, config :: Maybe FilePath
} deriving (Show, Generic, HasArguments)
data OfflineException = OfflineException
deriving (Show, Exception)
remoteCodec :: TomlCodec RemoteRef
remoteCodec = RemoteRef
<$> T.text "url" .= repourl
<*> T.text "ref" .= reporef
<*> T.text "name" .= reponame
orgCodec :: TomlCodec (Org False)
orgCodec = Org
<$> T.text "slug" .= orgSlug
<*> T.string "lintconfig" .= orgLintconfig
<*> T.string "entrypoint" .= orgEntrypoint
<*> T.int "generation" .= orgGeneration
<*> T.list remoteCodec "repo" .= orgRepos
<*> T.text "url" .= orgUrl
<*> T.text "webdir" .= orgWebdir
<*> T.text "backlink_prefix" .= orgBacklinkPrefix
<*> T.text "contact_mail" .= orgContactMail
<*> coerce (T.first T.text "howto_link") .= orgHowtoLink
-- why exactly does everything in tomland need to be invertable
urlBimap :: TomlBiMap BaseUrl String
urlBimap = BiMap
(Right . show)
(mapLeft (ArbitraryError . show) . parseBaseUrl)
configCodec :: TomlCodec (Config False)
configCodec = Config
<$> T.string "tmpdir" .= _tmpdir
<*> T.int "port" .= _port
<*> T.bool "verbose" .= _verbose
<*> T.int "interval" .= _interval
<*> coerce (T.first (T.match (urlBimap >>> T._String)) "exneuland") .= _exneuland
-- First is just Maybe but with different semantics
<*> 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@Org{..} = do
lintconfig <-
eitherDecodeFileStrict' orgLintconfig >>= \case
Right (c :: LintConfig Basic) -> pure c
Left err -> error $ show err
pure $ org { orgLintconfig =
feedConfig lintconfig (map reponame orgRepos) orgSlug }
data RealtimeMsg = RelintPending | Reload
deriving (Generic, ToJSON)
type RealtimeChannel = TChan RealtimeMsg
-- | a job status (of a specific uuid)
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
-- | the server's global state; might eventually end up with more
-- stuff in here, hence the newtype
newtype ServerState = ServerState
{ _unState :: Map Text (Org True, Map Sha1 (RemoteRef, JobStatus, Maybe JobStatus)) }
deriving Generic
-- instance NFData LintConfig' => NFData ServerState
makeLenses ''ServerState
-- | the inital state must already contain empty orgs, since setJobStatus
-- will default to a noop otherwise
emptyState :: Config True -> ServerState
emptyState config = ServerState
$ M.fromList $ map (\org -> (orgSlug org, (org, mempty))) (view orgs config)
-- | NOTE: this does not create the org if it does not yet exist!
overJobStatus
:: MVar ServerState
-> Org True
-> RemoteRef
-> (Maybe (RemoteRef, JobStatus, Maybe JobStatus) ->
Maybe (RemoteRef, JobStatus, Maybe JobStatus))
-> IO (Maybe (RemoteRef, JobStatus, Maybe JobStatus))
overJobStatus mvar !org !ref overState = 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 …
bla <- evaluateWHNF (view (unState . ix (orgSlug org) . _2) state)
let thing = state & (unState . ix (orgSlug org) . _2 . at (toSha ref)) %~ overState
pure (thing, view (at (toSha ref)) bla)
getJobStatus
:: MVar ServerState
-> Text
-> Sha1
-> IO (Maybe (Org True, RemoteRef, JobStatus, Maybe JobStatus))
getJobStatus mvar orgslug sha = withMVar mvar $ \state -> pure $ do
(org, jobs) <- view (unState . at orgslug) state
(ref, status, rev) <- M.lookup sha jobs
Just (org, ref, status, rev)
-- | the path (relative to a baseurl / webdir) where an adjusted
-- map should go
adjustedPath :: Text -> Org True -> Text -- TODO: filepath library using Text?
adjustedPath rev org@Org {..} =
orgWebdir <> "/" <> adjustedWebPath rev org
adjustedWebPath :: Text -> Org True -> Text
adjustedWebPath rev Org {..} =
rev <> show orgGeneration
newRealtimeChannel :: IO RealtimeChannel
newRealtimeChannel = atomically newBroadcastTChan
server/Worker.hs 0 → 100644
View file @ d3dcb5f4
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-}
module Worker (linterThread, Job(..)) where
import Universum
import CheckDir (recursiveCheckDir,
resultIsFatal, shrinkDirResult)
import Control.Concurrent.Async (async, link)
import Control.Concurrent.STM (writeTChan)
import Control.Concurrent.STM.TQueue
import Control.Exception (IOException, handle, throw)
import Control.Monad.Logger (logError, logErrorN, logInfoN,
runStdoutLoggingT)
import qualified Data.Text as T
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import Fmt ((+|), (|+))
import GHC.IO.Exception (ioException)
import LintConfig (stuffConfig)
import Server (Config, JobStatus (..),
Org (..),
RealtimeMsg (RelintPending, Reload),
RemoteRef (..), ServerState,
adjustedPath,
newRealtimeChannel,
overJobStatus, tmpdir)
import System.Directory (doesDirectoryExist)
import System.Exit (ExitCode (ExitFailure, ExitSuccess))
import System.FilePath ((</>))
import System.Process
import WriteRepo (writeAdjustedRepository)
data Job = Job
{ jobRef :: RemoteRef
, jobOrg :: Org True
}
linterThread :: Bool -> Config True -> TQueue Job -> MVar ServerState -> IO Void
linterThread offline config queue done = forever $ do
next <- atomically (readTQueue queue)
-- TODO: this doesn't guard against two jobs running on the same repo!
job <- async $ runJob offline config next done
-- TODO: is this a good idea? will crash the server if a job thread fails
link job
-- | the actual check function. Calls out to git to update the
-- repository, create a new worktree, lints it, then tells git to
-- delete that tree again.
--
-- May occasionally be brittle (if someone else changed files)
-- TODO: re-add proper fancy (colourful?) logging
runJob :: Bool -> Config True -> Job -> MVar ServerState -> IO ()
runJob offline config Job {..} done = do
rand <- UUID.nextRandom
let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand)
handle whoops
$ finally (lint workdir) (cleanup workdir)
where
lintConfig = stuffConfig (orgLintconfig jobOrg) (reponame jobRef)
lint workdir = runStdoutLoggingT $ do
-- set the "is being linted" flag in the assembly's state
-- (to show on the site even after reloads etc.)
oldstate <- liftIO $ overJobStatus done jobOrg jobRef $ \case
Just (ref, Linted res rev (_, realtime), oldstatus) ->
Just (ref, Linted res rev (True, realtime), oldstatus)
a -> a
-- send an update message to all connected websocket clients
maybeRealtime <- case oldstate of
Just (_, Linted _ _ (_, realtime), _) -> do
atomically $ writeTChan realtime RelintPending
pure (Just realtime)
_ -> pure Nothing
-- TODO: these calls fail for dumb http, add some fallback!
liftIO (doesDirectoryExist gitdir) >>= \case
False | offline -> logErrorN $ "offline mode but not cached; linting "
<> show gitdir <> " will fail"
| otherwise ->
(liftIO $ callProcess "git"
[ "clone", toString url, "--bare"
, "--depth", "1", "-b", toString ref, gitdir])
True | offline -> logInfoN $ "offline mode: not updating " <> show gitdir
| otherwise ->
(liftIO $ callgit gitdir
[ "fetch", "origin", toString (ref <> ":" <> ref) ])
rev <- map T.strip -- git returns a newline here
$ readgit' gitdir ["rev-parse", toString ref]
let outPath = adjustedPath rev jobOrg
callgit gitdir [ "worktree", "add", "--force", workdir, toString ref ]
res <- liftIO $ recursiveCheckDir lintConfig workdir (orgEntrypoint jobOrg)
>>= evaluateNF
liftIO (writeAdjustedRepository lintConfig workdir (toString outPath) res)
>>= \case
ExitSuccess ->
logInfoN $ "linted map "+| (show jobRef :: Text) |+"."
ExitFailure 1 ->
logInfoN $ "linted map "+| (show jobRef :: Text) |+ ", which failed."
ExitFailure 2 ->
-- TODO: shouldn't have linted this map at all
logErrorN $ "outpath "+|outPath|+" already exists!"
ExitFailure _ ->
-- writeAdjustedRepository does not return other codes
$(logError) "wtf, this is impossible"
realtime <- case maybeRealtime of
Just realtime -> do
atomically $ writeTChan realtime Reload
pure realtime
Nothing ->
liftIO newRealtimeChannel
-- the fact that `realtime` can't be defined in here is horrifying
void $ liftIO $ overJobStatus done jobOrg jobRef $ \maybeOld ->
let status = Linted (shrinkDirResult res) rev (False, realtime)
lastvalid = case maybeOld of
Just (_,_,lastvalid) -> lastvalid
Nothing -> Nothing
in Just ( jobRef
, status
, if resultIsFatal lintConfig res
then lastvalid
else Just status
)
cleanup workdir = do
callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ]
whoops (error :: IOException) = runStdoutLoggingT $ do
logErrorN (show error)
void $ liftIO $ overJobStatus done jobOrg jobRef $ \case
Nothing -> Just (jobRef, Failed (show error), Nothing)
Just (_,_,lastvalid) -> Just (jobRef, Failed (show error), lastvalid)
url = repourl jobRef
ref = reporef jobRef
gitdir = view tmpdir config </> toString hashedname
hashedname = T.map escapeSlash url
where escapeSlash = \case { '/' -> '-'; a -> a }
readgit' :: MonadIO m => FilePath -> [String] -> m Text
readgit' dir args = map toText $
liftIO $ do
print args
readProcess "git" ([ "-C", toString dir ] <> args) ""
callgit :: MonadIO m => FilePath -> [String] -> m ()
callgit dir args =
liftIO $ do
print args
callProcess "git" ([ "-C", toString dir ] <> args)
src/Main.hs
View file @ d3dcb5f4
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Control.Monad (unless)
import Control.Monad.Identity (Identity)
import Data.Aeson (eitherDecode, encode)
import Universum
import Data.Aeson (eitherDecodeFileStrict', encode)
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Aeson.KeyMap (coercionToHashMap)
import qualified Data.ByteString.Lazy as LB
import Data.Maybe (fromMaybe)
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import System.Exit (ExitCode (..), exitWith)
import WithCli
import WithCli (HasArguments, withCli)
import CheckDir (recursiveCheckDir, resultIsFatal, DirResult (dirresultGraph))
import Control.Monad (when)
import LintConfig (LintConfig (..), patchConfig)
import System.IO (hPutStrLn, stderr)
import CheckDir (recursiveCheckDir, resultIsFatal)
import LintConfig (ConfigKind (..), LintConfig (..),
patchConfig)
import System.Exit (ExitCode (ExitFailure))
import Types (Level (..))
import Util (printPretty)
import qualified Version as V (version)
import WriteRepo (writeAdjustedRepository)
import Text.Dot (showDot)
-- | the options this cli tool can take
data Options = Options
......@@ -45,7 +41,7 @@ data Options = Options
-- ^ path to write the (possibly adjusted) maps to after linting
, configFile :: Maybe FilePath
-- ^ path to a config file. Currently required.
, config :: Maybe (LintConfig Maybe)
, config :: Maybe (LintConfig Patch)
-- ^ a "patch" for the configuration file
, version :: Bool
, dot :: Bool
......@@ -56,52 +52,46 @@ main :: IO ()
main = withCli run
run :: Options -> IO ()
run options = do
run Options { .. } = do
aesonWarning
when (version options) $ do
if version then
putStrLn V.version
exitWith ExitSuccess
let repo = fromMaybe "." (repository options)
let entry = fromMaybe "main.json" (entrypoint options)
let level = fromMaybe Suggestion (lintlevel options)
lintconfig <- case configFile options of
Nothing -> error "Need a config file!"
Just path -> LB.readFile path >>= \res ->
case eitherDecode res :: Either String (LintConfig Identity) of
Left err -> error $ "config file invalid: " <> err
Right file -> pure (patchConfig file (config options))
lints <- recursiveCheckDir lintconfig repo entry
if | dot options ->
putStrLn (showDot $ dirresultGraph lints)
| json options ->
printLB
$ if pretty options then encodePretty lints else encode lints
| otherwise -> printPretty (level, lints)
case out options of
Nothing -> exitWith $ case resultIsFatal lintconfig lints of
False -> ExitSuccess
True -> ExitFailure 1
Just outpath -> do
c <- writeAdjustedRepository lintconfig repo outpath lints
unless (json options) $
case c of
ExitFailure 1 -> putStrLn "\nMap failed linting!"
ExitFailure 2 -> putStrLn "\nOutpath already exists, not writing anything."
_ -> pure ()
exitWith c
-- | haskell's many string types are FUN …
printLB :: LB.ByteString -> IO ()
printLB a = T.putStrLn $ T.decodeUtf8 $ LB.toStrict a
else do
let repo = fromMaybe "." repository
let entry = fromMaybe "main.json" entrypoint
let level = fromMaybe Suggestion lintlevel
configFile' <- case configFile of
Nothing -> do
hPutStrLn stderr ("option --config-file=FILEPATH required" :: Text)
exitFailure
Just path -> pure path
lintconfig <- eitherDecodeFileStrict' configFile' >>= \case
Left err -> error $ "config file invalid: " <> toText err
Right file -> pure (patchConfig file config)
lints <- recursiveCheckDir lintconfig repo entry
if json
then putText
$ decodeUtf8 (if pretty then encodePretty lints else encode lints)
else printPretty (level, lints)
case out of
Nothing
| resultIsFatal lintconfig lints -> exitWith (ExitFailure 1)
| otherwise -> exitSuccess
Just outpath -> do
c <- writeAdjustedRepository lintconfig repo outpath lints
unless json $
case c of
ExitFailure 1 ->
putTextLn "\nMap failed linting!"
ExitFailure 2 ->
putTextLn "\nOutpath already exists, not writing anything."
_ -> pass
exitWith c
-- if Aesons's internal map and HashMap are the same type, then coercionToHashMap
......@@ -112,10 +102,10 @@ printLB a = T.putStrLn $ T.decodeUtf8 $ LB.toStrict a
aesonWarning :: IO ()
aesonWarning = case coercionToHashMap of
Just _ -> hPutStrLn stderr
"Warning: this program was compiled using an older version of the Aeson Library\n\
("Warning: this program was compiled using an older version of the Aeson Library\n\
\used for parsing JSON, which is susceptible to hash flooding attacks.\n\
\n\
\Recompiling with a newer version is recommended when handling untrusted inputs.\n\
\n\
\See https://cs-syd.eu/posts/2021-09-11-json-vulnerability for details."
_ -> pure ()
\See https://cs-syd.eu/posts/2021-09-11-json-vulnerability for details." :: Text)
_ -> pass
src/Version.hs
View file @ d3dcb5f4
......@@ -3,13 +3,15 @@
module Version ( version ) where
import Control.Monad.Trans (liftIO)
import Universum
import qualified Language.Haskell.TH as TH
import System.Process (readProcess)
version :: String
version = "walint rc3 2021 (" <>
version = "walint divoc bb3 2022 (" <>
$(do
hash <- liftIO $ readProcess "git" ["rev-parse", "HEAD"] ""
hash <- liftIO $ catchAny (readProcess "git" ["rev-parse", "HEAD"] "")
(\_ -> pure "[unknown]")
pure . TH.LitE . TH.StringL $ take 40 hash) ++
")"
stack.yaml
View file @ d3dcb5f4
# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# https://docs.haskellstack.org/en/stable/yaml_configuration/
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
#
# The location of a snapshot can be provided as a file or url. Stack assumes
# a snapshot provided as a file might change, whereas a url resource does not.
#
# resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml
resolver:
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/16.yaml
resolver: lts-18.25
# User packages to be built.
# Various formats can be used as shown in the example below.
......@@ -41,36 +21,27 @@ extra-deps:
- semialign-1.2.0.1@sha256:5efc30d6f53f8d2a8a26d9bf3a57c0f20f4ba3086797ccaa615f644abc21d42e,2814
- text-short-0.1.4@sha256:4f7a76e78baf391d262883007e8f8d8fb23a2805d56d9725d6abdf1428542e11,3575
- time-compat-1.9.6.1@sha256:381a2e8ed6e41d20ff5929d12d25c1d9337d459de5964ef1d90b06d115b31f07,5033
- HList-0.5.1.0@sha256:3ecb2d10ad2b3d36ad28e2f08505f9c3d7143ca737ef13b3e64db503635966c2,7525
- cli-extras-0.1.0.2@sha256:404552a3e5e844f332fcf74858999b9b9b6d5dcab6017a9d5a48868715a21468,1996
- logging-effect-1.3.12@sha256:72d168dd09887649ba9501627219b6027cbec2d5541931555b7885b133785ce3,1679
- which-0.2@sha256:db82ca7d83d64cce8ad579756f02d27c5bd289806ee02474726f7fafb87318e8,858
- cli-git-0.1.0.2@sha256:4e62e6b7357e4fe698df8b58ba53919f9d4a056e9617dbc00c869a365e316387,1122
- servant-lucid-0.9.0.4@sha256:698db96903a145fdef40cc897f8790728642af917c37b941a98b2da872b65f08,1787
- servant-websockets-2.0.0@sha256:6e9e3600bced90fd52ed3d1bf632205cb21479075b20d6637153cc4567000234,2253
# mustache is on stackage, but in a version that doesn't yet support aeson 2.0
- mustache-2.4.0@sha256:bd1cfbd027c04d8329877e95413d34dc357d4bee041dd8978cd6a23b114fbda1,3180
allow-newer: true
# - acme-missiles-0.3
# - git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
#
# extra-deps: []
# Override default flag values for local packages and extra-deps
# use aeson with a non-hash-floodable implementation
flags:
aeson:
ordered-keymap: true
# Extra package databases containing global packages
# extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
#
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=2.7"
#
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
#
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
#
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor
nix:
enable: true
packages:
- zlib.dev
- zlib
- openssl
- git
- cacert
stack.yaml.lock
View file @ d3dcb5f4
......@@ -39,10 +39,65 @@ packages:
sha256: dd54303f712dd2b8dc05942061921b0d06e0bd501b42c965a9ac6a0a37cd3128
original:
hackage: time-compat-1.9.6.1@sha256:381a2e8ed6e41d20ff5929d12d25c1d9337d459de5964ef1d90b06d115b31f07,5033
snapshots:
- completed:
size: 586286
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/16.yaml
sha256: cdead65fca0323144b346c94286186f4969bf85594d649c49c7557295675d8a5
hackage: HList-0.5.1.0@sha256:3ecb2d10ad2b3d36ad28e2f08505f9c3d7143ca737ef13b3e64db503635966c2,7525
pantry-tree:
size: 5800
sha256: fe9d53555847bd16ffd46e3fb6013751c23f375a95d05b4d4c8de0bb22911e72
original:
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/16.yaml
hackage: HList-0.5.1.0@sha256:3ecb2d10ad2b3d36ad28e2f08505f9c3d7143ca737ef13b3e64db503635966c2,7525
- completed:
hackage: cli-extras-0.1.0.2@sha256:404552a3e5e844f332fcf74858999b9b9b6d5dcab6017a9d5a48868715a21468,1996
pantry-tree:
size: 849
sha256: 0f78dd9ad144dd81d2567ff0c47c111e2764db1b48341b34a2026018fb7f01ff
original:
hackage: cli-extras-0.1.0.2@sha256:404552a3e5e844f332fcf74858999b9b9b6d5dcab6017a9d5a48868715a21468,1996
- completed:
hackage: logging-effect-1.3.12@sha256:72d168dd09887649ba9501627219b6027cbec2d5541931555b7885b133785ce3,1679
pantry-tree:
size: 330
sha256: 3907e21147987af4f1590abce025e7439f0d338444f259791068c361d586117f
original:
hackage: logging-effect-1.3.12@sha256:72d168dd09887649ba9501627219b6027cbec2d5541931555b7885b133785ce3,1679
- completed:
hackage: which-0.2@sha256:db82ca7d83d64cce8ad579756f02d27c5bd289806ee02474726f7fafb87318e8,858
pantry-tree:
size: 262
sha256: bef8458bddea924f3162e51fcef66cb3071f73c31d3dbb6d4029b0115af88a54
original:
hackage: which-0.2@sha256:db82ca7d83d64cce8ad579756f02d27c5bd289806ee02474726f7fafb87318e8,858
- completed:
hackage: cli-git-0.1.0.2@sha256:4e62e6b7357e4fe698df8b58ba53919f9d4a056e9617dbc00c869a365e316387,1122
pantry-tree:
size: 269
sha256: 1e81c51e2b60db2b1784901cf0af33c67384f5412ad8edaad8a7068135f5217f
original:
hackage: cli-git-0.1.0.2@sha256:4e62e6b7357e4fe698df8b58ba53919f9d4a056e9617dbc00c869a365e316387,1122
- completed:
hackage: servant-lucid-0.9.0.4@sha256:698db96903a145fdef40cc897f8790728642af917c37b941a98b2da872b65f08,1787
pantry-tree:
size: 392
sha256: 39e0e7b2b25980bfe4df036e89959188f9ef9e8c78c85e241fa9a682d1d78cf3
original:
hackage: servant-lucid-0.9.0.4@sha256:698db96903a145fdef40cc897f8790728642af917c37b941a98b2da872b65f08,1787
- completed:
hackage: servant-websockets-2.0.0@sha256:6e9e3600bced90fd52ed3d1bf632205cb21479075b20d6637153cc4567000234,2253
pantry-tree:
size: 523
sha256: 085c6620bff7671bef1d969652a349271c3703fbf10dd753cb63ee1cd700bca5
original:
hackage: servant-websockets-2.0.0@sha256:6e9e3600bced90fd52ed3d1bf632205cb21479075b20d6637153cc4567000234,2253
- completed:
hackage: mustache-2.4.0@sha256:bd1cfbd027c04d8329877e95413d34dc357d4bee041dd8978cd6a23b114fbda1,3180
pantry-tree:
size: 1182
sha256: 44c4d43ecfe1fee11fb03ffd49b0580ed00eec5144067092801ef4256df77ef8
original:
hackage: mustache-2.4.0@sha256:bd1cfbd027c04d8329877e95413d34dc357d4bee041dd8978cd6a23b114fbda1,3180
snapshots:
- completed:
size: 587393
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/25.yaml
sha256: 1b74fb5e970497b5aefae56703f1bd44aa648bd1a5ef95c1eb8c29775087e2bf
original: lts-18.25
static/Genos-VariableFont_wght.ttf 0 → 100644
View file @ d3dcb5f4
File added
static/Ubuntu-R.ttf 0 → 100644
View file @ d3dcb5f4
File added
static/bootstrap.min.css 0 → 100755
View file @ d3dcb5f4
This diff is collapsed.
static/d3-graphviz.js 0 → 100644
View file @ d3dcb5f4
This diff is collapsed.
static/d3-graphviz.js.map 0 → 100644
View file @ d3dcb5f4
This diff is collapsed.

Impressum - Datenschutzerklärung