{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Inferno.VersionControl.Server where

import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (link, withAsync)
import Control.Monad (forever)
import Control.Monad.Except (ExceptT, runExceptT)
import Control.Monad.Reader (ReaderT, runReaderT)
import Data.Aeson (FromJSON, ToJSON)
import Data.Functor.Contravariant (contramap)
import qualified Data.Map as Map
import Data.Proxy (Proxy (..))
import Data.Set (Set)
import Data.String (fromString)
import qualified Data.Text as T
import GHC.Generics (Generic)
import Inferno.Types.Syntax (Expr)
import Inferno.Types.Type (TCScheme)
import Inferno.VersionControl.Log (VCServerTrace (ThrownVCStoreError), vcServerTraceToString)
import qualified Inferno.VersionControl.Operations as Ops
import qualified Inferno.VersionControl.Operations.Error as Ops
import Inferno.VersionControl.Server.Types (ServerConfig (..), readServerConfig)
import Inferno.VersionControl.Server.UnzipRequest (ungzipRequest)
import Inferno.VersionControl.Types
  ( Pinned,
    VCHashUpdate,
    VCMeta (..),
    VCObject (..),
    VCObjectHash,
    showVCObjectType,
  )
import Network.Wai.Handler.Warp
  ( defaultSettings,
    runSettings,
    setHost,
    setPort,
    setTimeout,
  )
import Network.Wai.Middleware.Gzip (def, gzip)
import Plow.Logging (IOTracer (..), simpleStdOutTracer, traceWith)
import Servant.API (Capture, JSON, ReqBody, Union, (:<|>) (..), (:>))
import Servant.Server (Handler, Server, serve)
import Servant.Typed.Error
  ( DeleteTypedError,
    GetTypedError,
    PostTypedError,
    WithError,
    liftTypedError,
  )

newtype VCServerError = VCServerError {VCServerError -> VCStoreError
serverError :: Ops.VCStoreError}
  deriving (forall x. Rep VCServerError x -> VCServerError
forall x. VCServerError -> Rep VCServerError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep VCServerError x -> VCServerError
$cfrom :: forall x. VCServerError -> Rep VCServerError x
Generic, Int -> VCServerError -> ShowS
[VCServerError] -> ShowS
VCServerError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VCServerError] -> ShowS
$cshowList :: [VCServerError] -> ShowS
show :: VCServerError -> String
$cshow :: VCServerError -> String
showsPrec :: Int -> VCServerError -> ShowS
$cshowsPrec :: Int -> VCServerError -> ShowS
Show)
  deriving newtype ([VCServerError] -> Encoding
[VCServerError] -> Value
VCServerError -> Encoding
VCServerError -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [VCServerError] -> Encoding
$ctoEncodingList :: [VCServerError] -> Encoding
toJSONList :: [VCServerError] -> Value
$ctoJSONList :: [VCServerError] -> Value
toEncoding :: VCServerError -> Encoding
$ctoEncoding :: VCServerError -> Encoding
toJSON :: VCServerError -> Value
$ctoJSON :: VCServerError -> Value
ToJSON, Value -> Parser [VCServerError]
Value -> Parser VCServerError
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [VCServerError]
$cparseJSONList :: Value -> Parser [VCServerError]
parseJSON :: Value -> Parser VCServerError
$cparseJSON :: Value -> Parser VCServerError
FromJSON)

type GetThrowingVCStoreError resp ty = GetTypedError resp ty VCServerError

type PostThrowingVCStoreError resp ty = PostTypedError resp ty VCServerError

type DeleteThrowingVCStoreError resp ty = DeleteTypedError resp ty VCServerError

type VersionControlAPI a g =
  "fetch" :> "function" :> Capture "hash" VCObjectHash :> GetThrowingVCStoreError '[JSON] (VCMeta a g (Expr (Pinned VCObjectHash) (), TCScheme))
    :<|> "fetch" :> "functions" :> ReqBody '[JSON] (Set g) :> PostThrowingVCStoreError '[JSON] [VCMeta a g VCObjectHash]
    :<|> "fetch" :> Capture "hash" VCObjectHash :> GetThrowingVCStoreError '[JSON] (VCMeta a g VCObject)
    :<|> "fetch" :> Capture "hash" VCObjectHash :> "history" :> GetThrowingVCStoreError '[JSON] [VCMeta a g VCObjectHash]
    :<|> "fetch" :> "objects" :> ReqBody '[JSON] [VCObjectHash] :> PostThrowingVCStoreError '[JSON] (Map.Map VCObjectHash (VCMeta a g VCObject))
    :<|> "fetch" :> "object" :> Capture "hash" VCObjectHash :> "closure" :> "hashes" :> GetThrowingVCStoreError '[JSON] [VCObjectHash]
    :<|> "push" :> "function" :> ReqBody '[JSON] (VCMeta a g (Expr (Pinned VCObjectHash) (), TCScheme)) :> PostThrowingVCStoreError '[JSON] VCObjectHash
    :<|> "delete" :> "autosave" :> "function" :> ReqBody '[JSON] VCObjectHash :> DeleteThrowingVCStoreError '[JSON] ()
    :<|> "delete" :> "scripts" :> Capture "hash" VCObjectHash :> DeleteThrowingVCStoreError '[JSON] ()

vcServer :: (VCHashUpdate a, VCHashUpdate g, FromJSON a, FromJSON g, ToJSON a, ToJSON g, Ord g) => FilePath -> IOTracer VCServerTrace -> Server (VersionControlAPI a g)
vcServer :: forall a g.
(VCHashUpdate a, VCHashUpdate g, FromJSON a, FromJSON g, ToJSON a,
 ToJSON g, Ord g) =>
String -> IOTracer VCServerTrace -> Server (VersionControlAPI a g)
vcServer String
config IOTracer VCServerTrace
tracer =
  forall a.
ReaderT
  (VCStorePath, IOTracer VCServerTrace)
  (ExceptT VCServerError Handler)
  a
-> Handler (Union (WithError VCServerError a))
toHandler forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {err} {m :: * -> *} {env} {author} {group}.
(MonadError err m, AsType VCStoreError err,
 HasType (IOTracer VCServerTrace) env, HasType VCStorePath env,
 MonadIO m, FromJSON author, FromJSON group, MonadReader env m) =>
VCObjectHash
-> m (VCMeta
        author group (Expr (Pinned VCObjectHash) (), TCScheme))
fetchFunctionH
    forall a b. a -> b -> a :<|> b
:<|> forall a.
ReaderT
  (VCStorePath, IOTracer VCServerTrace)
  (ExceptT VCServerError Handler)
  a
-> Handler (Union (WithError VCServerError a))
toHandler forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env (m :: * -> *) err g a.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m, Ord g,
 FromJSON a, FromJSON g) =>
Set g -> m [VCMeta a g VCObjectHash]
Ops.fetchFunctionsForGroups
    forall a b. a -> b -> a :<|> b
:<|> forall a.
ReaderT
  (VCStorePath, IOTracer VCServerTrace)
  (ExceptT VCServerError Handler)
  a
-> Handler (Union (WithError VCServerError a))
toHandler forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env (m :: * -> *) err a g.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m,
 FromJSON a, FromJSON g) =>
VCObjectHash -> m (VCMeta a g VCObject)
Ops.fetchVCObject
    forall a b. a -> b -> a :<|> b
:<|> forall a.
ReaderT
  (VCStorePath, IOTracer VCServerTrace)
  (ExceptT VCServerError Handler)
  a
-> Handler (Union (WithError VCServerError a))
toHandler forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env (m :: * -> *) err a g.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m,
 FromJSON a, FromJSON g) =>
VCObjectHash -> m [VCMeta a g VCObjectHash]
Ops.fetchVCObjectHistory
    forall a b. a -> b -> a :<|> b
:<|> forall a.
ReaderT
  (VCStorePath, IOTracer VCServerTrace)
  (ExceptT VCServerError Handler)
  a
-> Handler (Union (WithError VCServerError a))
toHandler forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env (m :: * -> *) err a g.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m,
 FromJSON a, FromJSON g) =>
[VCObjectHash] -> m (Map VCObjectHash (VCMeta a g VCObject))
Ops.fetchVCObjects
    forall a b. a -> b -> a :<|> b
:<|> forall a.
ReaderT
  (VCStorePath, IOTracer VCServerTrace)
  (ExceptT VCServerError Handler)
  a
-> Handler (Union (WithError VCServerError a))
toHandler forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env (m :: * -> *) err.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m) =>
VCObjectHash -> m [VCObjectHash]
Ops.fetchVCObjectClosureHashes
    forall a b. a -> b -> a :<|> b
:<|> forall a.
ReaderT
  (VCStorePath, IOTracer VCServerTrace)
  (ExceptT VCServerError Handler)
  a
-> Handler (Union (WithError VCServerError a))
toHandler forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {env} {m :: * -> *} {err} {a} {g}.
(MonadReader env m, MonadIO m, AsType VCStoreError err,
 MonadError err m, HasType (IOTracer VCServerTrace) env,
 HasType VCStorePath env, VCHashUpdate a, VCHashUpdate g, ToJSON a,
 ToJSON g) =>
VCMeta a g (Expr (Pinned VCObjectHash) (), TCScheme)
-> m VCObjectHash
pushFunctionH
    forall a b. a -> b -> a :<|> b
:<|> forall a.
ReaderT
  (VCStorePath, IOTracer VCServerTrace)
  (ExceptT VCServerError Handler)
  a
-> Handler (Union (WithError VCServerError a))
toHandler forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env (m :: * -> *) err.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m) =>
VCObjectHash -> m ()
Ops.deleteAutosavedVCObject
    forall a b. a -> b -> a :<|> b
:<|> forall a.
ReaderT
  (VCStorePath, IOTracer VCServerTrace)
  (ExceptT VCServerError Handler)
  a
-> Handler (Union (WithError VCServerError a))
toHandler forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env (m :: * -> *) err.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m) =>
VCObjectHash -> m ()
Ops.deleteVCObjects
  where
    fetchFunctionH :: VCObjectHash
-> m (VCMeta
        author group (Expr (Pinned VCObjectHash) (), TCScheme))
fetchFunctionH VCObjectHash
h = do
      om :: VCMeta author group VCObject
om@VCMeta {VCObject
obj :: forall author group o. VCMeta author group o -> o
obj :: VCObject
obj} <- forall env (m :: * -> *) err a g.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m,
 FromJSON a, FromJSON g) =>
VCObjectHash -> m (VCMeta a g VCObject)
Ops.fetchVCObject VCObjectHash
h
      case VCObject
obj of
        VCFunction Expr (Pinned VCObjectHash) ()
f TCScheme
t -> forall (f :: * -> *) a. Applicative f => a -> f a
pure VCMeta author group VCObject
om {obj :: (Expr (Pinned VCObjectHash) (), TCScheme)
obj = (Expr (Pinned VCObjectHash) ()
f, TCScheme
t)}
        VCObject
_ -> forall env (m :: * -> *) err a.
(VCStoreLogM env m, VCStoreErrM err m) =>
VCStoreError -> m a
Ops.throwError forall a b. (a -> b) -> a -> b
$ VCObjectHash -> Text -> VCStoreError
Ops.UnexpectedObjectType VCObjectHash
h forall a b. (a -> b) -> a -> b
$ VCObject -> Text
showVCObjectType VCObject
obj

    pushFunctionH :: VCMeta a g (Expr (Pinned VCObjectHash) (), TCScheme)
-> m VCObjectHash
pushFunctionH meta :: VCMeta a g (Expr (Pinned VCObjectHash) (), TCScheme)
meta@VCMeta {obj :: forall author group o. VCMeta author group o -> o
obj = (Expr (Pinned VCObjectHash) ()
f, TCScheme
t)} = forall env (m :: * -> *) err a g.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m,
 VCHashUpdate a, VCHashUpdate g, ToJSON a, ToJSON g) =>
VCMeta a g VCObject -> m VCObjectHash
Ops.storeVCObject VCMeta a g (Expr (Pinned VCObjectHash) (), TCScheme)
meta {obj :: VCObject
obj = Expr (Pinned VCObjectHash) () -> TCScheme -> VCObject
VCFunction Expr (Pinned VCObjectHash) ()
f TCScheme
t}

    toHandler :: ReaderT (Ops.VCStorePath, IOTracer VCServerTrace) (ExceptT VCServerError Handler) a -> Handler (Union (WithError VCServerError a))
    toHandler :: forall a.
ReaderT
  (VCStorePath, IOTracer VCServerTrace)
  (ExceptT VCServerError Handler)
  a
-> Handler (Union (WithError VCServerError a))
toHandler = forall (m :: * -> *) e a.
Functor m =>
ExceptT e m a -> m (Union '[WithStatus200 a, WithStatus500 e])
liftTypedError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (String -> VCStorePath
Ops.VCStorePath String
config, IOTracer VCServerTrace
tracer)

runServer :: forall proxy a g. (VCHashUpdate a, VCHashUpdate g, FromJSON a, FromJSON g, ToJSON a, ToJSON g, Ord g) => proxy a -> proxy g -> IO ()
runServer :: forall (proxy :: * -> *) a g.
(VCHashUpdate a, VCHashUpdate g, FromJSON a, FromJSON g, ToJSON a,
 ToJSON g, Ord g) =>
proxy a -> proxy g -> IO ()
runServer proxy a
proxyA proxy g
proxyG = do
  String -> IO (Either String ServerConfig)
readServerConfig String
"config.yml" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left String
err -> String -> IO ()
putStrLn String
err
    Right ServerConfig
serverConfig -> forall (proxy :: * -> *) a g.
(VCHashUpdate a, VCHashUpdate g, FromJSON a, FromJSON g, ToJSON a,
 ToJSON g, Ord g) =>
proxy a -> proxy g -> ServerConfig -> IO ()
runServerConfig proxy a
proxyA proxy g
proxyG ServerConfig
serverConfig

runServerConfig :: forall proxy a g. (VCHashUpdate a, VCHashUpdate g, FromJSON a, FromJSON g, ToJSON a, ToJSON g, Ord g) => proxy a -> proxy g -> ServerConfig -> IO ()
runServerConfig :: forall (proxy :: * -> *) a g.
(VCHashUpdate a, VCHashUpdate g, FromJSON a, FromJSON g, ToJSON a,
 ToJSON g, Ord g) =>
proxy a -> proxy g -> ServerConfig -> IO ()
runServerConfig proxy a
_ proxy g
_ ServerConfig
serverConfig = do
  let host :: HostPreference
host = forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerConfig -> Text
_serverHost forall a b. (a -> b) -> a -> b
$ ServerConfig
serverConfig
      port :: Int
port = ServerConfig -> Int
_serverPort ServerConfig
serverConfig
      vcPath :: String
vcPath = ServerConfig -> String
_vcPath ServerConfig
serverConfig
      settingsWithTimeout :: Settings
settingsWithTimeout = Int -> Settings -> Settings
setTimeout Int
300 Settings
defaultSettings
      tracer :: IOTracer VCServerTrace
tracer = forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap VCServerTrace -> String
vcServerTraceToString forall a b. (a -> b) -> a -> b
$ forall a.
(forall (m :: * -> *). MonadIO m => Tracer m a) -> IOTracer a
IOTracer forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => Tracer m String
simpleStdOutTracer
      deleteOp :: ReaderT
  (VCStorePath, IOTracer VCServerTrace) (ExceptT VCServerError IO) ()
deleteOp = forall env (m :: * -> *) err.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m) =>
m ()
Ops.deleteStaleAutosavedVCObjects :: ReaderT (Ops.VCStorePath, IOTracer VCServerTrace) (ExceptT VCServerError IO) ()
      cleanup :: IO ()
cleanup =
        (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (String -> VCStorePath
Ops.VCStorePath String
vcPath, IOTracer VCServerTrace
tracer) ReaderT
  (VCStorePath, IOTracer VCServerTrace) (ExceptT VCServerError IO) ()
deleteOp) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left (VCServerError {VCStoreError
serverError :: VCStoreError
serverError :: VCServerError -> VCStoreError
serverError}) ->
            forall (x :: * -> *) (m :: * -> *) a.
TraceWith x m =>
x a -> a -> m ()
traceWith @IOTracer IOTracer VCServerTrace
tracer (VCStoreError -> VCServerTrace
ThrownVCStoreError VCStoreError
serverError)
          Right ()
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT forall env (m :: * -> *). VCStoreEnvM env m => m ()
Ops.initVCStore forall a b. (a -> b) -> a -> b
$ String -> VCStorePath
Ops.VCStorePath String
vcPath
  forall a. Show a => a -> IO ()
print (String
"running..." :: String)
  -- Cleanup stale autosave scripts in a separate thread every hour:
  forall a b. IO a -> IO b -> IO b
withLinkedAsync_ (forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
3600000000 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
cleanup) forall a b. (a -> b) -> a -> b
$
    -- And run the server:
    Settings -> Application -> IO ()
runSettings (Int -> Settings -> Settings
setPort Int
port forall a b. (a -> b) -> a -> b
$ HostPreference -> Settings -> Settings
setHost HostPreference
host Settings
settingsWithTimeout) forall a b. (a -> b) -> a -> b
$
      Middleware
ungzipRequest forall a b. (a -> b) -> a -> b
$
        GzipSettings -> Middleware
gzip forall a. Default a => a
def forall a b. (a -> b) -> a -> b
$
          forall api.
HasServer api '[] =>
Proxy api -> Server api -> Application
serve (forall {k} (t :: k). Proxy t
Proxy :: Proxy (VersionControlAPI a g)) forall a b. (a -> b) -> a -> b
$ forall a g.
(VCHashUpdate a, VCHashUpdate g, FromJSON a, FromJSON g, ToJSON a,
 ToJSON g, Ord g) =>
String -> IOTracer VCServerTrace -> Server (VersionControlAPI a g)
vcServer String
vcPath IOTracer VCServerTrace
tracer

withLinkedAsync_ :: IO a -> IO b -> IO b
withLinkedAsync_ :: forall a b. IO a -> IO b -> IO b
withLinkedAsync_ IO a
f IO b
g = forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync IO a
f forall a b. (a -> b) -> a -> b
$ \Async a
h -> forall a. Async a -> IO ()
link Async a
h forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO b
g