basic server setup (using servant)

adds a very basic http server that can be sent links to repositories &
will download & lint them, then answer the request with the lints.

Should probably do this in a non-blocking way …

7 files changed, 274 insertions, 3 deletions

diff --git a/package.yaml b/package.yaml
index b3684cd..95ed5fb 100644
--- a/package.yaml
+++ b/package.yaml
@@ -43,10 +43,30 @@ executables:
   walint:
     main: Main.hs
     source-dirs: 'src'
-    build-tools: hspec-discover
     dependencies:
       - walint
       - getopt-generics
       - aeson-pretty
       - template-haskell
       - process
+  server:
+    main: Main.hs
+    source-dirs: 'server'
+    dependencies:
+      - time
+      - servant
+      - servant-server
+      - wai
+      - base-compat
+      - string-conversions
+      - http-media
+      - warp
+      - cli-git
+      - cli-extras
+      - filepath
+      - logging-effect
+      - process
+      - extra
+      - directory
+      - walint
+      - uuid
diff --git a/server/Git.hs b/server/Git.hs
new file mode 100644
index 0000000..e32d801
--- /dev/null
+++ b/server/Git.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE DataKinds        #-}
+{-# LANGUAGE DeriveAnyClass   #-}
+{-# LANGUAGE DeriveGeneric    #-}
+{-# LANGUAGE LambdaCase       #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Git (App, submitImpl) where
+
+import           Bindings.Cli.Git       (gitProc)
+import           CheckDir               (DirResult, recursiveCheckDir)
+import           Cli.Extras             (CliT, ProcessFailure, Severity (..),
+                                         callProcessAndLogOutput)
+import           Control.Monad.Extra    (ifM)
+import           Control.Monad.IO.Class (liftIO)
+import           Data.Text              (Text)
+import qualified Data.Text              as T
+import qualified Data.UUID              as UUID
+import qualified Data.UUID.V4           as UUID
+import           Servant
+import           Serverconfig
+import           System.Directory       (doesDirectoryExist)
+import           System.FilePath        ((</>))
+
+
+-- | this servant app can run cli programs!
+type App = CliT ProcessFailure Handler
+
+-- | annoying (and afaik unused), but has to be here for type system reasons
+instance MonadFail Handler where
+  fail _ = throwError $ err500
+
+-- | someone submitted a map; lint it (synchronously for now)
+submitImpl :: Config True -> RemoteRef -> App DirResult
+submitImpl config ref = do
+  ifM (liftIO $ doesDirectoryExist gitdir)
+    (callProcessAndLogOutput (Debug, Error) gitfetch)
+    (callProcessAndLogOutput (Debug, Error) gitclone)
+  checkPath config gitdir (reporef ref)
+  where gitclone = gitProc gitdir -- TODO: these calls fail for dumb http, add some fallback!
+          [ "clone", T.unpack $ repourl ref, "--bare", "--depth", "1", "-b", T.unpack (reporef ref)]
+        gitfetch = gitProc gitdir
+          [ "fetch", "origin", T.unpack (reporef ref), "--depth", "1" ]
+        gitdir = tmpdir config </> hashedname
+        hashedname = fmap escapeSlash . T.unpack . repourl $ ref
+        escapeSlash = \case
+          '/' -> '-'
+          a   -> a
+
+checkPath :: Config True -> FilePath -> Text -> App DirResult
+checkPath config gitdir ref = do
+  rand <- liftIO $ UUID.nextRandom
+  let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand)
+  callProcessAndLogOutput (Debug, Error)
+    $ gitProc gitdir [ "worktree", "add", workdir ]
+  callProcessAndLogOutput (Debug, Error)
+    $ gitProc workdir [ "checkout", T.unpack ref ]
+  res <- liftIO $ recursiveCheckDir (lintconfig config) gitdir (entrypoint config)
+  callProcessAndLogOutput (Debug, Error)
+    $ gitProc gitdir [ "worktree", "remove", "-f", "-f", workdir ]
+  pure res
diff --git a/server/Main.hs b/server/Main.hs
new file mode 100644
index 0000000..77c8fde
--- /dev/null
+++ b/server/Main.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures             #-}
+{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TypeApplications           #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE TypeOperators              #-}
+
+
+-- | simple server offering linting "as a service"
+module Main where
+
+import           CheckDir                   (DirResult)
+import           Cli.Extras                 (mkDefaultCliConfig, runCli)
+import           Control.Monad.IO.Class     (liftIO)
+import qualified Data.ByteString.Lazy.Char8 as C8
+import           Data.Text                  (Text)
+import           Git                        (App, submitImpl)
+import           Network.Wai.Handler.Warp   (run)
+import           Servant
+import           Serverconfig               (Config (..), RemoteRef (..),
+                                             loadConfig)
+
+{-
+Needed:
+ - admin overview (perhaps on seperate port?)
+ - in json:
+   - submit a repository link & ref name, get back job id
+   - look up a lint status by job id
+ - in html
+   - look up a lint status, pretty-printed
+   - front page with overview & links
+   - possibly a "update & relint" button?
+   - links to documentation
+-}
+-- | Main API type
+type API format =
+       "submit" :> ReqBody '[JSON] RemoteRef :> Get '[format] DirResult
+  :<|> "status" :> Capture "sha1" Text :> Get '[format] [Int]
+
+-- | API's implementation
+jsonAPI :: Config True -> ServerT (API JSON) App
+jsonAPI config =
+  submitImpl config
+  :<|> (\sha -> do
+          liftIO $ print sha
+          pure [1])
+
+-- | make an application; convert any cli errors into a 500
+app :: Config True -> Application
+app config =
+  serve api $ hoistServer api conv (jsonAPI config)
+  where api = Proxy @(API JSON)
+        conv :: App a -> Handler a
+        conv m = do
+          config <- liftIO $ mkDefaultCliConfig []
+          res <- runCli config m
+          case res of
+            Right a  -> pure a
+            Left err -> throwError (err500 { errBody = C8.pack (show err) })
+
+main :: IO ()
+main = do
+  let config = Config "/tmp" 8080 "main.json" "./config.json"
+  config' <- loadConfig config
+  run (port config) (app config')
diff --git a/server/Serverconfig.hs b/server/Serverconfig.hs
new file mode 100644
index 0000000..d919567
--- /dev/null
+++ b/server/Serverconfig.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DeriveAnyClass      #-}
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE KindSignatures      #-}
+{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeOperators       #-}
+
+module Serverconfig (loadConfig, Config(..), RemoteRef(..)) where
+
+import           Data.Aeson           (FromJSON, eitherDecode)
+import qualified Data.ByteString.Lazy as LB
+import           Data.Text            (Text)
+import           GHC.Generics         (Generic)
+import           LintConfig           (LintConfig')
+
+-- | a reference in a remote git repository
+data RemoteRef = RemoteRef
+  { repourl :: Text
+  , reporef :: Text
+  } deriving (Generic, FromJSON)
+
+type family ConfigRes (b :: Bool) a where
+  ConfigRes True a = a
+  ConfigRes False a = FilePath
+
+-- | the server's configuration
+data Config l = Config
+  { tmpdir     :: FilePath
+  -- ^ dir to clone git things in
+  , port       :: Int
+  -- ^ port to bind to
+  , entrypoint :: FilePath
+  , lintconfig :: ConfigRes l LintConfig'
+  }
+
+loadConfig :: Config False -> IO (Config True)
+loadConfig config = do
+  loaded <- LB.readFile (lintconfig config) >>= \res ->
+      case eitherDecode res :: Either String LintConfig' of
+        Left err   -> error $ "config file invalid: " <> err
+        Right file -> pure file
+  pure $ config { lintconfig = loaded }
diff --git a/stack.yaml b/stack.yaml
index 50475b0..738b3ad 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -23,6 +23,10 @@ extra-deps:
  - 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
 
 allow-newer: true
 
@@ -31,3 +35,11 @@ flags:
  aeson:
    ordered-keymap: true
 
+nix:
+  enable: true
+  packages:
+    - zlib.dev
+    - zlib
+    - openssl
+    - git
+    - cacert
diff --git a/stack.yaml.lock b/stack.yaml.lock
index 77b02f5..a7bbaf3 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -46,6 +46,34 @@ packages:
       sha256: fe9d53555847bd16ffd46e3fb6013751c23f375a95d05b4d4c8de0bb22911e72
   original:
     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
 snapshots:
 - completed:
     size: 586286
diff --git a/walint.cabal b/walint.cabal
index 73c5fd0..096d396 100644
--- a/walint.cabal
+++ b/walint.cabal
@@ -57,11 +57,43 @@ library
     , witherable
   default-language: Haskell2010
 
+executable server
+  main-is: Main.hs
+  other-modules:
+      Git
+      Serverconfig
+      Paths_walint
+  hs-source-dirs:
+      server
+  ghc-options: -Wall -Wno-name-shadowing
+  build-depends:
+      aeson
+    , base
+    , base-compat
+    , bytestring
+    , cli-extras
+    , cli-git
+    , directory
+    , extra
+    , filepath
+    , http-media
+    , logging-effect
+    , mtl
+    , process
+    , servant
+    , servant-server
+    , string-conversions
+    , text
+    , time
+    , uuid
+    , wai
+    , walint
+    , warp
+  default-language: Haskell2010
+
 executable walint
   main-is: Main.hs
   ghc-options: -Wall -Wno-name-shadowing
-  build-tool-depends:
-      hspec-discover:hspec-discover
   build-depends:
       aeson
     , aeson-pretty