@@ -7,20 +7,22 @@ import Data.Aeson qualified as A
77import Data.Aeson.Key qualified as Key
88import Data.Aeson.KeyMap qualified as KeyMap
99import Data.Aeson.Types qualified as A
10−import Data.ByteString.Base64 (decodeBase64)
10+import Data.Bifunctor (Bifunctor (..))
11+import Data.ByteString.Base64 (decodeBase64, encodeBase64)
1112import Data.Function
1213import Data.Functor
14+import Data.Set qualified as Set
1315import Data.Text (Text)
1416import Data.Text qualified as T
1517import Data.Text.Encoding qualified as T
1618import Data.Traversable
1719import Data.Vector qualified as V
18−import Debug.Trace
1920import GHC.Generics (Generic)
2021import Network.Wai.Handler.Warp qualified as Warp
2122import Options.Applicative
2223import ProjectM36.Base
2324import ProjectM36.Client
25+import ProjectM36.Relation (relationTrue)
2426import Servant
2527import Servant.Server.Generic
2628
@@ -38,6 +40,7 @@ options =
3840data Query
3941 = DefineQuery RelVarName [AttributeExpr]
4042 | InsertQuery RelVarName RelationalExpr
43+ | QueryQuery RelationalExpr
4144
4245instance FromJSON Query where
4346 parseJSON = withObject "Query" $ \o -> case KeyMap.toList o of
@@ -49,8 +52,51 @@ instance FromJSON Query where
4952 name <- i .: "name"
5053 rel <- i .: "rel" >>= decodeExpr
5154 pure $ InsertQuery name rel
55+ [("query", qry)] -> QueryQuery <$> decodeExpr qry
5256 _ -> fail "Poorly formed query key"
5357
58+encodeRelationType :: V.Vector Attribute -> A.Value
59+encodeRelationType =
60+ A.Array
61+ . fmap
62+ ( \(Attribute key t) ->
63+ toJSON . (key,) $ case t of
64+ IntAtomType -> A.String "int"
65+ IntegerAtomType -> A.String "integer"
66+ ScientificAtomType -> A.String "scientific"
67+ DoubleAtomType -> A.String "double"
68+ TextAtomType -> A.String "text"
69+ DayAtomType -> A.String "day"
70+ DateTimeAtomType -> A.String "datetime"
71+ ByteStringAtomType -> A.String "bytestring"
72+ BoolAtomType -> A.String "bool"
73+ UUIDAtomType -> A.String "uuid"
74+ RelationAtomType (Attributes attrs) -> encodeRelationType attrs
75+ _ -> error $ "unsupported atom type: " <> show t
76+ )
77+
78+encodeAtom :: Atom -> A.Value
79+encodeAtom = \case
80+ IntegerAtom a -> toJSON a
81+ IntAtom a -> toJSON a
82+ ScientificAtom a -> toJSON a
83+ DoubleAtom a -> toJSON a
84+ TextAtom a -> toJSON a
85+ DayAtom a -> toJSON a
86+ DateTimeAtom a -> toJSON a
87+ ByteStringAtom a -> toJSON $ encodeBase64 a
88+ BoolAtom a -> toJSON a
89+ UUIDAtom a -> toJSON a
90+ RelationAtom a -> encodeRelation a
91+ a -> error $ "Unsupported atom type: " <> show a
92+
93+encodeRelation :: Relation -> A.Value
94+encodeRelation (Relation (Attributes attrs) (RelationTupleSet tuples)) =
95+ A.object
96+ [ "attrs" A..= fmap (\(Attribute key _) -> key) attrs,
97+ "vals" A..= (tuples <&> (\(RelationTuple _ atoms) -> encodeAtom <$> atoms))
98+ ]
99+
54100decodeRelationType :: A.Array -> A.Parser (V.Vector Attribute)
55101decodeRelationType o =
56102 traverse parseJSON o
@@ -71,11 +117,11 @@ decodeRelationType o =
71117 _ -> fail $ "unknown type: " <> show v
72118 )
73119
74−decodeExpr :: A.Object -> A.Parser RelationalExpr
75−decodeExpr o = case KeyMap.toList (traceShowId o) of
120+decodeExpr :: A.Value -> A.Parser RelationalExpr
121+decodeExpr = withObject "Expr" $ \o -> case KeyMap.toList o of
76122 [("lit", A.Object lit)] -> do
77− (traceShowId -> !attrs) <- lit .: "attrs" >>= decodeRelationType
78− (traceShowId -> !vals) :: [V.Vector Value] <- lit .: "vals"
123+ attrs <- lit .: "attrs" >>= decodeRelationType
124+ vals :: [V.Vector Value] <- lit .: "vals"
79125 tuples <- for vals $ \rel ->
80126 traverse
81127 (uncurry decodeAtom)
@@ -84,10 +130,31 @@ decodeExpr o = case KeyMap.toList (traceShowId o) of
84130 MakeStaticRelation
85131 (Attributes attrs)
86132 (RelationTupleSet $ RelationTuple (Attributes attrs) <$> tuples)
133+ [("join", A.Array (V.toList -> [x, y]))] -> Join <$> decodeExpr x <*> decodeExpr y
134+ [("union", A.Array (V.toList -> [x, y]))] -> Union <$> decodeExpr x <*> decodeExpr y
135+ [("proj", A.Object p)] -> do
136+ proj <- AttributeNames <$> p .: "proj"
137+ expr <- p .: "expr" >>= decodeExpr
138+ pure $ Project proj expr
139+ [("rename", A.Object r)] -> do
140+ mapping <- r .: "mapping" <&> Set.fromList . fmap (first Key.toText) . KeyMap.toList
141+ expr <- r .: "expr" >>= decodeExpr
142+ pure $ Rename mapping expr
143+ [("diff", A.Array (V.toList -> [x, y]))] -> Difference <$> decodeExpr x <*> decodeExpr y
144+ [("group", A.Object g)] -> do
145+ attrs <- AttributeNames <$> g .: "attrs"
146+ attr <- g .: "attr"
147+ expr <- g .: "expr" >>= decodeExpr
148+ pure $ Group attrs attr expr
149+ [("ungroup", A.Object u)] -> do
150+ attr <- u .: "attr"
151+ expr <- u .: "expr" >>= decodeExpr
152+ pure $ Ungroup attr expr
153+ [("var", A.String v)] -> pure $ RelationVariable v ()
87154 _ -> fail $ "unknown expression: " <> show o
88155
89156decodeAtom :: AtomType -> A.Value -> A.Parser Atom
90−decodeAtom (traceShowId -> t) (traceShowId -> v) = case t of
157+decodeAtom t v = case t of
91158 IntAtomType -> IntAtom <$> parseJSON v
92159 IntegerAtomType -> IntegerAtom <$> parseJSON v
93160 ScientificAtomType -> ScientificAtom <$> parseJSON v
@@ -120,7 +187,7 @@ data API r = API
120187 { startTransaction :: r :- "transaction" :> Post '[JSON] SessionId,
121188 commit :: r :- "transaction" :> Capture "SessionId" SessionId :> PutNoContent,
122189 abort :: r :- "transaction" :> Capture "SessionId" SessionId :> DeleteNoContent,
123− query :: r :- "transaction" :> Capture "SessionId" SessionId :> ReqBody '[JSON] Query :> Post '[JSON] [A.Value]
190+ query :: r :- "transaction" :> Capture "SessionId" SessionId :> ReqBody '[JSON] Query :> Post '[JSON] A.Value
124191 }
125192 deriving stock (Generic)
126193
@@ -131,13 +198,15 @@ server conn =
131198 liftIO (createSessionAtHead conn defaultHeadName) >>= rethrow,
132199 commit = \sess -> (liftIO (autoMergeToHead sess conn UnionMergeStrategy defaultHeadName) >>= rethrow) $> NoContent,
133200 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 []
201+ query = \sess q ->
202+ encodeRelation <$> case q of
203+ DefineQuery varName attrs -> do
204+ liftIO (executeDatabaseContextExpr sess conn (Define varName attrs)) >>= rethrow
205+ pure relationTrue
206+ InsertQuery varName rel -> do
207+ liftIO (executeDatabaseContextExpr sess conn (Insert varName rel)) >>= rethrow
208+ pure relationTrue
209+ QueryQuery rel -> liftIO (executeRelationalExpr sess conn rel) >>= rethrow
141210 }
142211
143212rethrow :: (Show err) => Either err x -> Handler x