@@ -0,0 +1,163 @@
1+module ProjectM36.Rest (run) where
2+
3+import Control.Exception (bracket)
4+import Control.Monad.IO.Class
5+import Data.Aeson hiding (Options)
6+import Data.Aeson qualified as A
7+import Data.Aeson.Key qualified as Key
8+import Data.Aeson.KeyMap qualified as KeyMap
9+import Data.Aeson.Types qualified as A
10+import Data.ByteString.Base64 (decodeBase64)
11+import Data.Function
12+import Data.Functor
13+import Data.Text (Text)
14+import Data.Text qualified as T
15+import Data.Text.Encoding qualified as T
16+import Data.Traversable
17+import Data.Vector qualified as V
18+import Debug.Trace
19+import GHC.Generics (Generic)
20+import Network.Wai.Handler.Warp qualified as Warp
21+import Options.Applicative
22+import ProjectM36.Base
23+import ProjectM36.Client
24+import Servant
25+import Servant.Server.Generic
26+
27+data Options = Options
28+ { dir :: FilePath,
29+ port :: Warp.Port
30+ }
31+
32+options :: Parser Options
33+options =
34+ Options
35+ <$> strOption (short 'd' <> long "dir" <> help "Path to where project-m36 should store data." <> value "m36")
36+ <*> option auto (short 'p' <> long "port" <> help "Port on which the HTTP server should run" <> value 6543)
37+
38+data Query
39+ = DefineQuery RelVarName [AttributeExpr]
40+ | InsertQuery RelVarName RelationalExpr
41+
42+instance FromJSON Query where
43+ parseJSON = withObject "Query" $ \o -> case KeyMap.toList o of
44+ [("define", def)] -> flip (withObject "Definition") def $ \d -> do
45+ name <- d .: "name"
46+ attributes <- (d .: "attrs") >>= decodeRelationType
47+ pure $ DefineQuery name (NakedAttributeExpr <$> V.toList attributes)
48+ [("insert", ins)] -> flip (withObject "Insert") ins $ \i -> do
49+ name <- i .: "name"
50+ rel <- i .: "rel" >>= decodeExpr
51+ pure $ InsertQuery name rel
52+ _ -> fail "Poorly formed query key"
53+
54+decodeRelationType :: A.Array -> A.Parser (V.Vector Attribute)
55+decodeRelationType o =
56+ traverse parseJSON o
57+ >>= traverse
58+ ( \(key, v) ->
59+ Attribute (Key.toText key) <$> case v of
60+ A.String "int" -> pure IntAtomType
61+ A.String "integer" -> pure IntegerAtomType
62+ A.String "scientific" -> pure ScientificAtomType
63+ A.String "double" -> pure DoubleAtomType
64+ A.String "text" -> pure TextAtomType
65+ A.String "day" -> pure DayAtomType
66+ A.String "datetime" -> pure DateTimeAtomType
67+ A.String "bytestring" -> pure ByteStringAtomType
68+ A.String "bool" -> pure BoolAtomType
69+ A.String "uuid" -> pure UUIDAtomType
70+ A.Array x -> RelationAtomType . Attributes <$> decodeRelationType x
71+ _ -> fail $ "unknown type: " <> show v
72+ )
73+
74+decodeExpr :: A.Object -> A.Parser RelationalExpr
75+decodeExpr o = case KeyMap.toList (traceShowId o) of
76+ [("lit", A.Object lit)] -> do
77+ (traceShowId -> !attrs) <- lit .: "attrs" >>= decodeRelationType
78+ (traceShowId -> !vals) :: [V.Vector Value] <- lit .: "vals"
79+ tuples <- for vals $ \rel ->
80+ traverse
81+ (uncurry decodeAtom)
82+ (V.zip ((\(Attribute _ atomType) -> atomType) <$> attrs) rel)
83+ pure $
84+ MakeStaticRelation
85+ (Attributes attrs)
86+ (RelationTupleSet $ RelationTuple (Attributes attrs) <$> tuples)
87+ _ -> fail $ "unknown expression: " <> show o
88+
89+decodeAtom :: AtomType -> A.Value -> A.Parser Atom
90+decodeAtom (traceShowId -> t) (traceShowId -> v) = case t of
91+ IntAtomType -> IntAtom <$> parseJSON v
92+ IntegerAtomType -> IntegerAtom <$> parseJSON v
93+ ScientificAtomType -> ScientificAtom <$> parseJSON v
94+ DoubleAtomType -> DoubleAtom <$> parseJSON v
95+ TextAtomType -> TextAtom <$> parseJSON v
96+ DayAtomType -> DayAtom <$> parseJSON v
97+ DateTimeAtomType -> DateTimeAtom <$> parseJSON v
98+ ByteStringAtomType ->
99+ ByteStringAtom <$> do
100+ b64 <- T.encodeUtf8 <$> parseJSON @Text v
101+ case decodeBase64 b64 of
102+ Right x -> pure x
103+ Left err -> fail $ T.unpack err
104+ pure undefined
105+ BoolAtomType -> BoolAtom <$> parseJSON v
106+ UUIDAtomType -> UUIDAtom <$> parseJSON v
107+ RelationAtomType (Attributes attrs) -> do
108+ rels <- parseJSON @[(V.Vector Value)] v
109+ decodedRels <- for rels $ \rel ->
110+ for (V.zip attrs rel) $ \(Attribute _ t', a) ->
111+ decodeAtom t' a
112+ pure $
113+ RelationAtom $
114+ Relation (Attributes attrs) $
115+ RelationTupleSet $
116+ decodedRels <&> \rel -> RelationTuple (Attributes attrs) rel
117+ _ -> fail $ "Unsupported atom type: " <> show t
118+
119+data API r = API
120+ { startTransaction :: r :- "transaction" :> Post '[JSON] SessionId,
121+ commit :: r :- "transaction" :> Capture "SessionId" SessionId :> PutNoContent,
122+ abort :: r :- "transaction" :> Capture "SessionId" SessionId :> DeleteNoContent,
123+ query :: r :- "transaction" :> Capture "SessionId" SessionId :> ReqBody '[JSON] Query :> Post '[JSON] [A.Value]
124+ }
125+ deriving stock (Generic)
126+
127+server :: Connection -> API AsServer
128+server conn =
129+ API
130+ { startTransaction =
131+ liftIO (createSessionAtHead conn defaultHeadName) >>= rethrow,
132+ commit = \sess -> (liftIO (autoMergeToHead sess conn UnionMergeStrategy defaultHeadName) >>= rethrow) $> NoContent,
133+ abort = \sess -> liftIO (closeSession sess conn) $> NoContent,
134+ query = \sess -> \case
135+ DefineQuery varName attrs -> do
136+ liftIO (executeDatabaseContextExpr sess conn (Define varName attrs)) >>= rethrow
137+ pure []
138+ InsertQuery varName rel -> do
139+ liftIO (executeDatabaseContextExpr sess conn (Insert varName rel)) >>= rethrow
140+ pure []
141+ }
142+
143+rethrow :: (Show err) => Either err x -> Handler x
144+rethrow = \case
145+ Left err -> throwError err400 {errReasonPhrase = show err}
146+ Right x -> pure x
147+
148+run :: IO ()
149+run = do
150+ opts <- execParser $ info (helper <*> options) fullDesc
151+ bracket
152+ ( connectProjectM36
153+ (InProcessConnectionInfo (CrashSafePersistence opts.dir) emptyNotificationCallback [] basicDatabaseContext)
154+ >>= \case
155+ Left err -> error $ show err
156+ Right x -> pure x
157+ )
158+ close
159+ ( \conn ->
160+ Warp.runSettings
161+ (Warp.defaultSettings & Warp.setServerName "project-m36-rest" & Warp.setPort opts.port)
162+ (genericServe (server conn))
163+ )