256 lines
8.6 KiB
Haskell
256 lines
8.6 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE ApplicativeDo #-}
|
|
module Main where
|
|
|
|
import AutoTypes qualified as U
|
|
import AutoTypes.Unify qualified as U
|
|
import Control.Applicative ((<**>))
|
|
import Control.Concurrent
|
|
import Control.Concurrent.STM
|
|
import Control.Monad
|
|
import Control.Monad.Trans (liftIO)
|
|
import Data.Aeson qualified as J
|
|
import Data.Attoparsec.Char8 as P
|
|
import Data.ByteString.Lazy.UTF8 qualified as LB
|
|
import Data.Map qualified as M
|
|
import Data.Map.Merge.Strict qualified as M
|
|
import Data.Maybe
|
|
import Data.String (IsString (fromString))
|
|
import Data.Tagged (Tagged (..))
|
|
import Debug.Trace
|
|
import Git qualified as G
|
|
import Git.Libgit2 qualified as GB
|
|
import Network.HTTP.Types
|
|
import Network.HTTP.Types.Status qualified as W
|
|
import Network.Wai qualified as W
|
|
import Network.Wai.Handler.Warp qualified as W
|
|
import Options.Applicative qualified as A
|
|
import Route qualified as R
|
|
import Safe
|
|
import Store qualified as Q
|
|
import System.Directory (setCurrentDirectory, doesDirectoryExist, makeAbsolute)
|
|
import System.Exit
|
|
import System.FilePath
|
|
import System.INotify
|
|
import System.IO qualified as IO
|
|
import Version
|
|
|
|
data Args = Args
|
|
{ cmd :: Cmd
|
|
}
|
|
|
|
args :: A.Parser Args
|
|
args = Args <$> cmd'
|
|
|
|
data Cmd = Serve
|
|
{ serverPort :: Int
|
|
, contentRepositoryPath :: FilePath
|
|
}
|
|
|
|
cmd' :: A.Parser Cmd
|
|
cmd' =
|
|
A.hsubparser . mconcat $
|
|
[ A.command "serve" . A.info serveCmd $
|
|
A.progDesc "Run webserver"
|
|
]
|
|
|
|
serveCmd :: A.Parser Cmd
|
|
serveCmd = do
|
|
serverPort <- A.option A.auto (A.metavar "PORT" <> A.showDefault <> A.value 8081 <> A.long "port" <> A.short 'p' <> A.help "The server port")
|
|
contentRepositoryPath <- A.strArgument (A.metavar "PATH" <> A.help "Path to the content repository")
|
|
pure Serve {..}
|
|
|
|
data Repo = Repo
|
|
{ commits :: [Commit]
|
|
}
|
|
deriving (Show)
|
|
|
|
data Commit = Commit
|
|
{ id :: G.CommitOid GB.LgRepo,
|
|
collections :: [Collection],
|
|
schemaVersion :: Version
|
|
}
|
|
deriving (Show)
|
|
|
|
data Collection = Collection
|
|
{ path :: FilePath,
|
|
files :: [FilePath],
|
|
schema :: U.T
|
|
}
|
|
deriving (Show)
|
|
|
|
data Schema = Schema {unSchema :: J.Value}
|
|
deriving (Show)
|
|
|
|
instance J.ToJSON Schema where
|
|
toJSON = J.toJSON . (.unSchema)
|
|
|
|
fromAutoTypes :: String -> U.T -> Schema
|
|
fromAutoTypes path (U.Object ps) =
|
|
Schema $
|
|
J.object
|
|
[ ("$schema", J.toJSON @String "https://json-schema.org/draft/2020-12/schema"),
|
|
("$id", J.toJSON @String (path <> ".schema.json")),
|
|
("title", J.toJSON @String path),
|
|
("type", J.toJSON @String "object"),
|
|
("properties", J.toJSON (M.map toProperty ps))
|
|
]
|
|
where
|
|
toProperty (U.Scalar "string") = "string" :: String
|
|
toProperty (U.Option (Just (U.Scalar "string"))) = "string?" :: String
|
|
|
|
watch :: TMVar Repo -> FilePath -> G.RefName -> IO ()
|
|
watch repoT root ref = do
|
|
i <- initINotify
|
|
qT <- newTQueueIO
|
|
_ <-
|
|
addWatch i [MoveIn] ".git/refs/heads" $ \e ->
|
|
atomically (writeTQueue qT e)
|
|
forever do
|
|
repo <- initRepo root ref
|
|
atomically do putTMVar repoT repo
|
|
_ <- atomically do
|
|
let loop = maybe (pure ()) (const loop) =<< tryReadTQueue qT
|
|
readTQueue qT >> loop
|
|
_ <- atomically do takeTMVar repoT
|
|
pure ()
|
|
|
|
initRepo :: FilePath -> G.RefName -> IO Repo
|
|
initRepo root ref = do
|
|
repo <- G.openRepository GB.lgFactory G.defaultRepositoryOptions {G.repoPath = root}
|
|
G.runRepository GB.lgFactory repo do
|
|
Just cid <- fmap Tagged <$> G.resolveReference ref
|
|
cs <- mapM G.lookupCommit =<< G.listCommits Nothing cid
|
|
fmap (Repo . reverse) $
|
|
foldM
|
|
( \cs c -> do
|
|
let cid = G.commitOid c
|
|
fs <- liftIO $ Q.withStore root ref do
|
|
Q.withCommit cid (Q.listFiles "/")
|
|
let cls =
|
|
M.toList . M.unionsWith (++) $
|
|
map (\f -> M.singleton (takeDirectory f) [f]) fs
|
|
colls <- forM cls $ \(path, files) -> do
|
|
(value : values) <- do
|
|
liftIO . Q.withStore root ref . Q.withCommit cid $ do
|
|
Q.query (fromString ("SELECT " <> path <> " FROM " <> path))
|
|
let schema = U.autoTypes' value values
|
|
pure $ Collection path files schema
|
|
let schemaVersion =
|
|
case headMay cs of
|
|
Nothing -> Version 1 0 0
|
|
Just c' ->
|
|
let Version major' minor' patch' = c'.schemaVersion
|
|
schemas' =
|
|
M.fromList
|
|
( (\coll -> (coll.path, coll.schema))
|
|
<$> c'.collections
|
|
)
|
|
schemas =
|
|
M.fromList
|
|
( (\coll -> (coll.path, coll.schema))
|
|
<$> c.collections
|
|
)
|
|
in case compareSchemas schemas' schemas of
|
|
Just Major -> Version (major' + 1) 0 0
|
|
Just Minor -> Version major' (minor' + 1) 0
|
|
Just Patch -> Version major' minor' (patch' + 1)
|
|
Nothing -> Version major' minor' patch'
|
|
c = Commit cid colls schemaVersion
|
|
pure (c : cs)
|
|
)
|
|
[]
|
|
cs
|
|
|
|
compareSchemas ::
|
|
M.Map String U.T ->
|
|
M.Map String U.T ->
|
|
Maybe SchemaDifference
|
|
compareSchemas schemas' schemas =
|
|
maximumMay
|
|
. catMaybes
|
|
. M.elems
|
|
. M.map (uncurry compareSchemas')
|
|
$ M.merge
|
|
(M.mapMissing (\_ schema' -> (Just schema', Nothing)))
|
|
(M.mapMissing (\_ schema -> (Nothing, Just schema)))
|
|
(M.zipWithMatched (\_ schema' schema -> (Just schema', Just schema)))
|
|
schemas'
|
|
schemas
|
|
where
|
|
compareSchemas' Nothing Nothing = Nothing
|
|
compareSchemas' Nothing (Just _) = Just Minor
|
|
compareSchemas' (Just _) Nothing = Just Major
|
|
compareSchemas' (Just schema') (Just schema) = compareSchema schema' schema
|
|
|
|
compareSchema :: U.T -> U.T -> Maybe SchemaDifference
|
|
compareSchema (U.Object kts') (U.Object kts) = compareSchemas kts' kts
|
|
compareSchema t' t
|
|
| t' == t = Nothing
|
|
| t' `elem` (U.unify1 t' t) = Just Patch
|
|
| t `elem` U.unify1 t' t = Just Minor
|
|
| otherwise = Just Major
|
|
|
|
data SchemaDifference
|
|
= Major
|
|
| Minor
|
|
| Patch
|
|
deriving (Show, Eq, Ord)
|
|
|
|
logStderr :: String -> IO ()
|
|
logStderr = IO.hPutStrLn IO.stderr
|
|
|
|
main :: IO ()
|
|
main = do
|
|
A.execParser (A.info (args <**> A.helper) A.idm) >>= \case
|
|
Args {cmd = Serve {contentRepositoryPath, serverPort}} -> do
|
|
contentRepositoryPath' <- makeAbsolute contentRepositoryPath
|
|
contentRepositoryPathExists <- doesDirectoryExist (contentRepositoryPath' </> ".git")
|
|
|
|
unless contentRepositoryPathExists $ do
|
|
logStderr $ "Content repository '" ++ contentRepositoryPath ++ "' is not a git repository."
|
|
exitFailure
|
|
|
|
setCurrentDirectory contentRepositoryPath'
|
|
let root = "."
|
|
ref = "refs/heads/master"
|
|
repoT <- newEmptyTMVarIO
|
|
_ <- forkIO do watch repoT root ref
|
|
|
|
logStderr ("Serving " ++ contentRepositoryPath' ++ " on port " ++ show serverPort ++ ".")
|
|
|
|
W.runEnv serverPort $ \req respond -> do
|
|
case P.parseOnly R.parser (W.rawPathInfo req) of
|
|
Right (R.SchemaJson path) -> do
|
|
repo <- atomically (readTMVar repoT)
|
|
let [c] = filter ((== path) . (.path)) (last repo.commits).collections
|
|
respond . W.responseLBS W.status200 [] $
|
|
J.encode (fromAutoTypes path c.schema)
|
|
Right R.Query -> do
|
|
q <-
|
|
fromString @Q.Query . LB.toString
|
|
<$> W.lazyRequestBody req
|
|
r <- liftIO $ Q.withStore root ref do Q.query q
|
|
respond . W.responseLBS W.status200 [] $ J.encode r
|
|
Right R.SchemaVersion -> do
|
|
repo <- atomically (readTMVar repoT)
|
|
respond $
|
|
W.responseLBS W.status200 [] $
|
|
J.encode (last repo.commits).schemaVersion
|
|
Right R.Collections -> do
|
|
if
|
|
| W.requestMethod req == "POST" -> do
|
|
Right collection <- J.eitherDecode <$> W.lazyRequestBody req
|
|
Q.withStore root ref do
|
|
Q.writeFile (collection </> ".gitkeep") ""
|
|
Q.commit
|
|
respond $ W.responseLBS W.status200 [] "{}"
|
|
| W.requestMethod req == "GET" -> do
|
|
repo <- atomically (readTMVar repoT)
|
|
respond $
|
|
W.responseLBS W.status200 [] $
|
|
J.encode (map (.path) (last repo.commits).collections)
|
|
(traceShowId -> !_) ->
|
|
respond $ W.responseLBS W.status200 [] "not implemented"
|