diff --git a/package.yaml b/package.yaml index 89d5327..ae735b3 100644 --- a/package.yaml +++ b/package.yaml @@ -14,6 +14,9 @@ extra-source-files: dependencies: - base >= 4.7 && < 5 +- aeson +- text +- unordered-containers library: source-dirs: src diff --git a/src/Forest/Api.hs b/src/Forest/Api.hs new file mode 100644 index 0000000..d9dfb31 --- /dev/null +++ b/src/Forest/Api.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | This module contains all the types found in the API. + +module Forest.Api + ( + -- * Common + NodeId + , Node(..) + , Path(..) + -- * Client + , ClientPacket(..) + -- * Server + , ServerPacket(..) + ) where + +import Control.Applicative +import Control.Monad +import Data.Aeson +import Data.Aeson.Types +import qualified Data.HashMap.Strict as Map +import qualified Data.Text as T + +{- Common -} + +type NodeId = T.Text + +data Node = Node + { nodeText :: T.Text + , nodeAct :: Bool + , nodeEdit :: Bool + , nodeDelete :: Bool + , nodeReply :: Bool + , nodeChildren :: Map.HashMap NodeId Node + } deriving (Show) + +instance ToJSON Node where + toJSON node = object + [ "text" .= nodeText node + , "act" .= nodeAct node + , "edit" .= nodeEdit node + , "delete" .= nodeDelete node + , "reply" .= nodeReply node + , "children" .= nodeChildren node + ] + + toEncoding node = pairs + ( "text" .= nodeText node + <> "act" .= nodeAct node + <> "edit" .= nodeEdit node + <> "delete" .= nodeDelete node + <> "reply" .= nodeReply node + <> "children" .= nodeChildren node + ) + +instance FromJSON Node where + parseJSON v = parseJSON v >>= \o -> Node + <$> o .: "text" + <*> o .: "act" + <*> o .: "edit" + <*> o .: "delete" + <*> o .: "reply" + <*> o .: "children" + +newtype Path = Path + { pathElements :: [NodeId] + } deriving (Show, Eq) + +instance ToJSON Path where + toJSON = toJSON . pathElements + toEncoding = toEncoding . pathElements + +instance FromJSON Path where + parseJSON v = Path <$> parseJSON v + +parsePacket :: Value -> T.Text -> (Object -> Parser a) -> Parser a +parsePacket value packetType parser = parseJSON value >>= \o -> do + parsedPacketType <- o .: "type" + guard $ parsedPacketType == packetType + parser o + +{- Client -} + +data ClientPacket + = ClientHello [T.Text] + | ClientAct Path + | ClientEdit Path T.Text + | ClientDelete Path + | ClientReply Path T.Text + deriving (Show) + +instance ToJSON ClientPacket where + toJSON (ClientHello extensions) = + object ["type" .= ("hello" :: T.Text), "extensions" .= extensions] + toJSON (ClientAct path) = object ["type" .= ("act" :: T.Text), "path" .= path] + toJSON (ClientEdit path text) = + object ["type" .= ("edit" :: T.Text), "path" .= path, "text" .= text] + toJSON (ClientDelete path) = + object ["type" .= ("delete" :: T.Text), "path" .= path] + toJSON (ClientReply path text) = + object ["type" .= ("reply" :: T.Text), "path" .= path, "text" .= text] + + toEncoding (ClientHello extensions) = + pairs ("type" .= ("hello" :: T.Text) <> "extensions" .= extensions) + toEncoding (ClientAct path) = + pairs ("type" .= ("act" :: T.Text) <> "path" .= path) + toEncoding (ClientEdit path text) = + pairs ("type" .= ("edit" :: T.Text) <> "path" .= path <> "text" .= text) + toEncoding (ClientDelete path) = + pairs ("type" .= ("delete" :: T.Text) <> "path" .= path) + toEncoding (ClientReply path text) = + pairs ("type" .= ("reply" :: T.Text) <> "path" .= path <> "text" .= text) + +instance FromJSON ClientPacket where + parseJSON v = + parsePacket v "hello" (\o -> ClientHello <$> o .: "extensions") <|> + parsePacket v "act" (\o -> ClientAct <$> o .: "path") <|> + parsePacket v "edit" (\o -> ClientEdit <$> o .: "path" <*> o .: "text") <|> + parsePacket v "delete" (\o -> ClientDelete <$> o .: "path") <|> + parsePacket v "reply" (\o -> ClientReply <$> o .: "path" <*> o .: "text") + +{- Server -} + +data ServerPacket + = ServerHello [T.Text] + | ServerUpdate Path Node + deriving (Show) + +instance ToJSON ServerPacket where + toJSON (ServerHello extensions) = + object ["type" .= ("hello" :: T.Text), "extensions" .= extensions] + toJSON (ServerUpdate path node) = + object ["type" .= ("update" :: T.Text), "path" .= path, "node" .= node] + + toEncoding (ServerHello extensions) = + pairs ("type" .= ("hello" :: T.Text) <> "extensions" .= extensions) + toEncoding (ServerUpdate path node) = + pairs ("type" .= ("update" :: T.Text) <> "path" .= path <> "node" .= node) + +instance FromJSON ServerPacket where + parseJSON v = + parsePacket v "hello" (\o -> ServerHello <$> o .: "extensions") <|> + parsePacket v "update" (\o -> ServerUpdate <$> o .: "path" <*> o .: "node")