server: add a "panic i'm on a train"-offline mode

(this also adds general cli arguments, but the main point is that
downloading monstrously large repositories is a silly idea when i'm on a
train with surprisingly bad wifi)

5 files changed, 58 insertions, 32 deletions

diff --git a/package.yaml b/package.yaml
index 39efe0a..9d2f826 100644
--- a/package.yaml
+++ b/package.yaml
@@ -112,6 +112,7 @@ executables:
       - fmt
       - tomland
       - stm
+      - getopt-generics
       - async
       - cryptohash-sha1
       - uuid
diff --git a/server/Main.hs b/server/Main.hs
index 60098b6..6806ee7 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -1,6 +1,9 @@
 {-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DeriveAnyClass      #-}
+{-# LANGUAGE DeriveGeneric       #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
 {-# LANGUAGE TypeFamilies        #-}
@@ -39,7 +42,8 @@ import           Servant                              (Application, Capture,
                                                        type (:>))
 import           Servant.HTML.Lucid                   (HTML)
 import           Servant.Server.StaticFiles           (serveDirectoryWebApp)
-import           Server                               (JobStatus, Org (..),
+import           Server                               (CliOptions (..),
+                                                       JobStatus, Org (..),
                                                        ServerState, Sha1,
                                                        emptyState, exneuland,
                                                        interval, loadConfig,
@@ -53,6 +57,8 @@ import           Servant.API                          (Header)
 import           Servant.API.WebSocket                (WebSocketPending)
 import           Servant.Client                       (ClientM, client,
                                                        mkClientEnv, runClientM)
+import           Universum.Bool.Reexport              (Bool)
+import           WithCli                              (HasArguments, withCli)
 
 type family PolyEndpoint method format payload where
   PolyEndpoint Get format payload =
@@ -97,9 +103,11 @@ app queue = serve (Proxy @Routes) . server queue
 postNewMaps :: Maybe Text -> MapService -> ClientM Text
 postNewMaps = client (Proxy @(MapServiceAPI Post))
 
+
+
 main :: IO ()
-main = do
-  config <- loadConfig "./config.toml"
+main = withCli $ \CliOptions {..} -> do
+  config <- loadConfig (fromMaybe "./config.toml" config)
   state <- newMVar (emptyState config)
   queue :: TQueue Job <- newTQueueIO
   loggerMiddleware <- mkRequestLogger
@@ -117,7 +125,7 @@ main = do
     threadDelay (view interval config * 1000000)
 
   -- TODO: what about tls / https?
-  whenJust (view exneuland config) $ \baseurl -> do
+  unless offline $ whenJust (view exneuland config) $ \baseurl -> do
     manager' <- newManager defaultManagerSettings
     updater <- async $ runStdoutLoggingT $ forever $ do
       done <- readMVar state
@@ -129,7 +137,7 @@ main = do
     link updater
 
   -- spawns threads for each job in the queue
-  linter <- async $ void $ linterThread config queue state
+  linter <- async $ void $ linterThread offline config queue state
   link linter
   link poker
 
diff --git a/server/Server.hs b/server/Server.hs
index 3d783d7..3081997 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -24,6 +24,8 @@ module Server ( loadConfig
               , Org(..)
               , Sha1, toSha
               , Config, tmpdir, port, verbose, orgs, interval, exneuland, token
+              , CliOptions(..)
+              , OfflineException
               , RemoteRef(..)
               , ServerState, emptyState, unState
               , JobStatus(..)
@@ -57,6 +59,7 @@ import           Toml                         (BiMap (BiMap), TomlBiMap,
                                                TomlCodec,
                                                prettyTomlDecodeErrors, (.=))
 import qualified Toml                         as T
+import           WithCli                      (HasArguments)
 
 -- | a reference in a remote git repository
 data RemoteRef = RemoteRef
@@ -134,6 +137,13 @@ data Config (loaded :: Bool) = Config
 
 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
@@ -157,6 +167,7 @@ urlBimap = BiMap
   (Right . show)
   (mapLeft (ArbitraryError . show) . parseBaseUrl)
 
+
 configCodec :: TomlCodec (Config False)
 configCodec = Config
     <$> T.string "tmpdir" .= _tmpdir
@@ -171,7 +182,7 @@ configCodec = 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
+loadConfig  path = do
   res <- T.decodeFileEither configCodec path
   case res of
     Right config -> traverseOf orgs (mapM loadOrg) config
@@ -183,10 +194,8 @@ loadConfig path = do
           eitherDecodeFileStrict' orgLintconfig >>= \case
           Right (c :: LintConfig Basic) -> pure c
           Left err                      -> error $ show err
-        let config = org { orgLintconfig =
+        pure $ org { orgLintconfig =
                      feedConfig lintconfig (map reponame orgRepos) orgSlug }
-        print config
-        pure config
 
 data RealtimeMsg = RelintPending | Reload
   deriving (Generic, ToJSON)
diff --git a/server/Worker.hs b/server/Worker.hs
index 57b5b9f..31ddcdc 100644
--- a/server/Worker.hs
+++ b/server/Worker.hs
@@ -5,23 +5,25 @@
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell     #-}
+{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-}
 
 module Worker (linterThread, Job(..)) where
 
 import           Universum
 
 import           CheckDir                      (recursiveCheckDir,
-                                                shrinkDirResult, resultIsFatal)
+                                                resultIsFatal, shrinkDirResult)
 import           Control.Concurrent.Async      (async, link)
 import           Control.Concurrent.STM        (writeTChan)
 import           Control.Concurrent.STM.TQueue
-import           Control.Exception             (IOException, handle)
+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 (..),
@@ -29,7 +31,7 @@ import           Server                        (Config, JobStatus (..),
                                                 RemoteRef (..), ServerState,
                                                 adjustedPath,
                                                 newRealtimeChannel,
-                                                tmpdir, overJobStatus)
+                                                overJobStatus, tmpdir)
 import           System.Directory              (doesDirectoryExist)
 import           System.Exit                   (ExitCode (ExitFailure, ExitSuccess))
 import           System.FilePath               ((</>))
@@ -41,11 +43,11 @@ data Job = Job
   , jobOrg :: Org True
   }
 
-linterThread :: Config True -> TQueue Job -> MVar ServerState -> IO Void
-linterThread config queue done = forever $ do
+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 config next done
+  job <- async $ runJob offline config next done
   -- TODO: is this a good idea? will crash the server if a job thread fails
   link job
 
@@ -55,8 +57,8 @@ linterThread config queue done = forever $ do
 --
 -- May occasionally be brittle (if someone else changed files)
 -- TODO: re-add proper fancy (colourful?) logging
-runJob :: Config True -> Job -> MVar ServerState -> IO ()
-runJob config Job {..} done = do
+runJob :: Bool -> Config True -> Job -> MVar ServerState -> IO ()
+runJob offline config Job {..} done = do
   rand <- UUID.nextRandom
   let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand)
 
@@ -64,11 +66,11 @@ runJob config Job {..} done = do
     $ finally (lint workdir) (cleanup workdir)
   where
     lintConfig = stuffConfig (orgLintconfig jobOrg) (reponame jobRef)
-    lint workdir = do
+    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 <- overJobStatus done jobOrg jobRef $ \case
+      oldstate <- liftIO $ overJobStatus done jobOrg jobRef $ \case
         Just (ref, Linted res rev (_, realtime), oldstatus) ->
           Just (ref, Linted res rev (True, realtime), oldstatus)
         a -> a
@@ -80,13 +82,18 @@ runJob config Job {..} done = do
           pure (Just realtime)
         _ -> pure Nothing
 
-      ifM (doesDirectoryExist gitdir)
         -- TODO: these calls fail for dumb http, add some fallback!
-        (callgit gitdir
-         [ "fetch", "origin", toString ref, "--depth", "1" ])
-        (callProcess "git"
-         [ "clone", toString url, "--bare"
-         , "--depth", "1", "-b", toString ref, gitdir])
+      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, "--depth", "1" ])
       rev <- map T.strip -- git returns a newline here
         $ readgit' gitdir ["rev-parse", toString ref]
 
@@ -94,11 +101,11 @@ runJob config Job {..} done = do
 
       callgit gitdir [ "worktree", "add", "--force", workdir, toString ref ]
 
-      res <- recursiveCheckDir lintConfig workdir (orgEntrypoint jobOrg)
+      res <- liftIO $ recursiveCheckDir lintConfig workdir (orgEntrypoint jobOrg)
                >>= evaluateNF
 
-      writeAdjustedRepository lintConfig workdir (toString outPath) res
-        >>= runStdoutLoggingT . \case
+      liftIO (writeAdjustedRepository lintConfig workdir (toString outPath) res)
+        >>= \case
         ExitSuccess ->
           logInfoN $ "linted map "+| (show jobRef :: Text) |+"."
         ExitFailure 1 ->
@@ -115,14 +122,14 @@ runJob config Job {..} done = do
           atomically $ writeTChan realtime Reload
           pure realtime
         Nothing ->
-          newRealtimeChannel
+          liftIO newRealtimeChannel
 
       -- the fact that `realtime` can't be defined in here is horrifying
-      void $ overJobStatus done jobOrg jobRef $ \maybeOld ->
+      void $ liftIO $ overJobStatus done jobOrg jobRef $ \maybeOld ->
         let status = Linted (shrinkDirResult res) rev (False, realtime)
             lastvalid = case maybeOld of
               Just (_,_,lastvalid) -> lastvalid
-              Nothing -> Nothing
+              Nothing              -> Nothing
         in Just ( jobRef
                 , status
                 , if resultIsFatal lintConfig res
@@ -136,7 +143,7 @@ runJob config Job {..} done = do
     whoops (error :: IOException) = runStdoutLoggingT $ do
       logErrorN (show error)
       void $ liftIO $ overJobStatus done jobOrg jobRef $ \case
-        Nothing -> Just (jobRef, Failed (show error), Nothing)
+        Nothing              -> Just (jobRef, Failed (show error), Nothing)
         Just (_,_,lastvalid) -> Just (jobRef, Failed (show error), lastvalid)
 
     url = repourl jobRef
diff --git a/walint.cabal b/walint.cabal
index aa5f7d3..703cf4a 100644
--- a/walint.cabal
+++ b/walint.cabal
@@ -162,6 +162,7 @@ executable walint-mapserver
     , extra
     , filepath
     , fmt
+    , getopt-generics
     , http-client
     , http-types
     , lucid