{-# 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)
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
$
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