From cc52022f3b099287f0ac57eb514753202ef47db2 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Wed, 16 Feb 2022 19:38:08 +0100
Subject: server: post map updates to exneuland's API

---
 server/Server.hs | 29 +++++++++++++++++++++--------
 1 file changed, 21 insertions(+), 8 deletions(-)

(limited to 'server/Server.hs')

diff --git a/server/Server.hs b/server/Server.hs
index bcb96a0..ef01b88 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -19,7 +19,7 @@
 module Server ( loadConfig
               , Org(..)
               , Sha1
-              , Config, tmpdir, port, verbose, orgs, interval
+              , Config, tmpdir, port, verbose, orgs, interval, exneuland
               , RemoteRef(..)
               , ServerState, emptyState, unState
               , JobStatus(..)
@@ -29,6 +29,7 @@ module Server ( loadConfig
 import           Universum
 
 import           CheckDir                   (DirResult)
+import           Control.Arrow              ((>>>))
 import           Control.Concurrent         (modifyMVar_, withMVar)
 import           Crypto.Hash.SHA1           (hash)
 import           Data.Aeson                 (FromJSON, ToJSON, ToJSONKey (..),
@@ -40,9 +41,14 @@ import qualified Data.Map                   as M
 import           Lens.Micro.Platform        (at, ix, makeLenses, traverseOf)
 import           LintConfig                 (LintConfig')
 import           Servant                    (FromHttpApiData)
-import           Toml                       (TomlCodec, prettyTomlDecodeErrors,
-                                             (.=))
+import           Servant.Client             (BaseUrl,
+                                             parseBaseUrl)
+import           Toml                       (BiMap (BiMap), TomlBiMap,
+                                             TomlBiMapError (ArbitraryError),
+                                             TomlCodec,
+                                             prettyTomlDecodeErrors, (.=))
 import qualified Toml                       as T
+import Data.Either.Extra (mapLeft)
 
 -- | a reference in a remote git repository
 data RemoteRef = RemoteRef
@@ -103,13 +109,14 @@ instance ToJSONKey (Org True) where
 
 -- | the server's configuration
 data Config (loaded :: Bool) = Config
-  { _tmpdir   :: FilePath
+  { _tmpdir    :: FilePath
   -- ^ dir to clone git things in
-  , _port     :: Int
-  , _verbose  :: Bool
-  , _interval :: Int
+  , _port      :: Int
+  , _verbose   :: Bool
+  , _interval  :: Int
   -- ^ port to bind to
-  , _orgs     :: [Org loaded]
+  , _exneuland :: BaseUrl
+  , _orgs      :: [Org loaded]
   } deriving Generic
 
 makeLenses ''Config
@@ -130,6 +137,11 @@ orgCodec = Org
   <*> T.text "url" .= orgUrl
   <*> T.text "webdir" .= orgWebdir
 
+-- 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
@@ -137,6 +149,7 @@ configCodec = Config
     <*> T.int "port" .= _port
     <*> T.bool "verbose" .= _verbose
     <*> T.int "interval" .= _interval
+    <*> T.match (urlBimap >>> T._String) "exneuland" .= _exneuland
     <*> T.list orgCodec "org" .= _orgs
 
 -- | a job status (of a specific uuid)
-- 
cgit v1.2.3