{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- Module      : Docs.TreeRevision
-- Description : A Revision of a Tree
-- License     : AGPL-3
-- Maintainer  : stu235271@mail.uni-kiel.de
--               stu236925@mail.uni-kiel.de
--
-- This module contains definitions and related utility functions for revisions of the
-- document structure tree.
module Docs.TreeRevision
    ( TreeRevisionID (..)
    , TreeRevision (..)
    , TreeRevisionHeader (..)
    , TreeRevisionSelector (..)
    , TreeRevisionHistory (..)
    , TreeRevisionRef (..)
    , prettyPrintTreeRevisionRef
    , mapRoot
    , mapMRoot
    , replaceRoot
    , withTextRevisions
    , newTreeRevision
    , specificTreeRevision
    , latestTreeRevisionAsOf
    ) where

import Control.Monad (unless)
import Data.Functor ((<&>))
import Data.Proxy (Proxy (Proxy))
import Data.Scientific (toBoundedInteger)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Time (UTCTime)

import Text.Read (readMaybe)

import GHC.Generics (Generic)
import GHC.Int (Int64)

import Control.Lens ((&), (.~), (?~))
import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=))
import qualified Data.Aeson as Aeson
import qualified Data.HashMap.Strict.InsOrd as InsOrd
import Data.OpenApi
    ( HasFormat (format)
    , NamedSchema (..)
    , OpenApiType (..)
    , Referenced (Inline)
    , ToParamSchema (..)
    , ToSchema (..)
    , declareSchemaRef
    , enum_
    , exclusiveMinimum
    , minimum_
    , oneOf
    , properties
    , required
    , type_
    )
import Web.HttpApiData (FromHttpApiData (..))

import UserManagement.User (UserID)

import Data.Typeable (typeRep)
import Docs.Document (DocumentID (..))
import Docs.TextElement (TextElement, TextElementID)
import Docs.TextRevision (TextElementRevision, TextRevision)
import Docs.Tree (Node)
import qualified Docs.Tree as Tree
import Docs.UserRef (UserRef)
import Parse (parseFlexibleTime)

-- | References a @TreeRevision@
data TreeRevisionRef
    = TreeRevisionRef
        DocumentID
        TreeRevisionSelector
    deriving ((forall x. TreeRevisionRef -> Rep TreeRevisionRef x)
-> (forall x. Rep TreeRevisionRef x -> TreeRevisionRef)
-> Generic TreeRevisionRef
forall x. Rep TreeRevisionRef x -> TreeRevisionRef
forall x. TreeRevisionRef -> Rep TreeRevisionRef x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TreeRevisionRef -> Rep TreeRevisionRef x
from :: forall x. TreeRevisionRef -> Rep TreeRevisionRef x
$cto :: forall x. Rep TreeRevisionRef x -> TreeRevisionRef
to :: forall x. Rep TreeRevisionRef x -> TreeRevisionRef
Generic)

instance ToJSON TreeRevisionRef

instance FromJSON TreeRevisionRef

instance ToSchema TreeRevisionRef

-- | Optisch ansprechende Darstellung der Baum-Revisions-Referenz.
prettyPrintTreeRevisionRef :: TreeRevisionRef -> String
prettyPrintTreeRevisionRef :: TreeRevisionRef -> String
prettyPrintTreeRevisionRef (TreeRevisionRef DocumentID
treeElementRef TreeRevisionSelector
selector) =
    Int64 -> String
forall a. Show a => a -> String
show (DocumentID -> Int64
unDocumentID DocumentID
treeElementRef) String -> String -> String
forall a. [a] -> [a] -> [a]
++ TreeRevisionSelector -> String
prettyPrintSelector TreeRevisionSelector
selector
  where
    prettyPrintSelector :: TreeRevisionSelector -> String
prettyPrintSelector TreeRevisionSelector
Latest = String
"latest"
    prettyPrintSelector (LatestAsOf UTCTime
ts) = UTCTime -> String
forall a. Show a => a -> String
show UTCTime
ts
    prettyPrintSelector (Specific TreeRevisionID
revID) = Int64 -> String
forall a. Show a => a -> String
show (Int64 -> String) -> Int64 -> String
forall a b. (a -> b) -> a -> b
$ TreeRevisionID -> Int64
unTreeRevisionID TreeRevisionID
revID

-- | Selector for a tree revision.
data TreeRevisionSelector
    = -- | select the latest revision
      Latest
    | -- | selects the latest revision at a given timestamp
      LatestAsOf UTCTime
    | -- | selects a specific revision by its id
      Specific TreeRevisionID

instance ToJSON TreeRevisionSelector where
    toJSON :: TreeRevisionSelector -> Value
toJSON TreeRevisionSelector
Latest = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text
"latest" :: Text)
    toJSON (LatestAsOf UTCTime
ts) = UTCTime -> Value
forall a. ToJSON a => a -> Value
toJSON UTCTime
ts
    toJSON (Specific TreeRevisionID
id_) = TreeRevisionID -> Value
forall a. ToJSON a => a -> Value
toJSON TreeRevisionID
id_

instance FromJSON TreeRevisionSelector where
    parseJSON :: Value -> Parser TreeRevisionSelector
parseJSON Value
v = case Value
v of
        Aeson.String Text
"latest" -> TreeRevisionSelector -> Parser TreeRevisionSelector
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TreeRevisionSelector
Latest
        Aeson.String Text
_ -> UTCTime -> TreeRevisionSelector
LatestAsOf (UTCTime -> TreeRevisionSelector)
-> Parser UTCTime -> Parser TreeRevisionSelector
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser UTCTime
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v -- TODO: parseFlexibleTime?
        Aeson.Number Scientific
n -> case Scientific -> Maybe Int64
forall i. (Integral i, Bounded i) => Scientific -> Maybe i
toBoundedInteger Scientific
n of
            Just Int64
i -> TreeRevisionSelector -> Parser TreeRevisionSelector
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TreeRevisionSelector -> Parser TreeRevisionSelector)
-> TreeRevisionSelector -> Parser TreeRevisionSelector
forall a b. (a -> b) -> a -> b
$ TreeRevisionID -> TreeRevisionSelector
Specific (TreeRevisionID -> TreeRevisionSelector)
-> TreeRevisionID -> TreeRevisionSelector
forall a b. (a -> b) -> a -> b
$ Int64 -> TreeRevisionID
TreeRevisionID Int64
i
            Maybe Int64
Nothing -> String -> Parser TreeRevisionSelector
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid number for Int64"
        Value
_ -> String -> Parser TreeRevisionSelector
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"TreeRevisionSelector must be either a string \"latest\" or an integer"

instance ToSchema TreeRevisionSelector where
    declareNamedSchema :: Proxy TreeRevisionSelector
-> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy TreeRevisionSelector
_ = do
        Referenced Schema
intSchema <- Proxy Int64 -> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
declareSchemaRef (Proxy Int64
forall {k} (t :: k). Proxy t
Proxy :: Proxy Int64)
        Referenced Schema
timestampSchema <- Proxy UTCTime -> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
declareSchemaRef (Proxy UTCTime
forall {k} (t :: k). Proxy t
Proxy :: Proxy UTCTime)
        let latestSchema :: Referenced Schema
latestSchema =
                Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Schema -> Referenced Schema) -> Schema -> Referenced Schema
forall a b. (a -> b) -> a -> b
$
                    Schema
forall a. Monoid a => a
mempty
                        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiString
                        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe [Value] -> Identity (Maybe [Value]))
-> Schema -> Identity Schema
forall s a. HasEnum s a => Lens' s a
Lens' Schema (Maybe [Value])
enum_ ((Maybe [Value] -> Identity (Maybe [Value]))
 -> Schema -> Identity Schema)
-> [Value] -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [Value
"latest"]
        NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$
            Maybe Text -> Schema -> NamedSchema
NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"TreeRevisionSelector") (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$
                Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe [Referenced Schema] -> Identity (Maybe [Referenced Schema]))
-> Schema -> Identity Schema
forall s a. HasOneOf s a => Lens' s a
Lens' Schema (Maybe [Referenced Schema])
oneOf ((Maybe [Referenced Schema]
  -> Identity (Maybe [Referenced Schema]))
 -> Schema -> Identity Schema)
-> [Referenced Schema] -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [Referenced Schema
latestSchema, Referenced Schema
intSchema, Referenced Schema
timestampSchema]

instance ToParamSchema TreeRevisionSelector where
    toParamSchema :: Proxy TreeRevisionSelector -> Schema
toParamSchema Proxy TreeRevisionSelector
_ =
        Schema
forall a. Monoid a => a
mempty
            Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe [Referenced Schema] -> Identity (Maybe [Referenced Schema]))
-> Schema -> Identity Schema
forall s a. HasOneOf s a => Lens' s a
Lens' Schema (Maybe [Referenced Schema])
oneOf
                ((Maybe [Referenced Schema]
  -> Identity (Maybe [Referenced Schema]))
 -> Schema -> Identity Schema)
-> [Referenced Schema] -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [ Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Schema -> Referenced Schema) -> Schema -> Referenced Schema
forall a b. (a -> b) -> a -> b
$
                        Schema
forall a. Monoid a => a
mempty
                            Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiString
                            Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe [Value] -> Identity (Maybe [Value]))
-> Schema -> Identity Schema
forall s a. HasEnum s a => Lens' s a
Lens' Schema (Maybe [Value])
enum_ ((Maybe [Value] -> Identity (Maybe [Value]))
 -> Schema -> Identity Schema)
-> [Value] -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [Value
"latest"]
                   , Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Schema -> Referenced Schema) -> Schema -> Referenced Schema
forall a b. (a -> b) -> a -> b
$
                        Schema
forall a. Monoid a => a
mempty
                            Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiString
                            Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text)) -> Schema -> Identity Schema
forall s a. HasFormat s a => Lens' s a
Lens' Schema (Maybe Text)
format ((Maybe Text -> Identity (Maybe Text))
 -> Schema -> Identity Schema)
-> Text -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
"date-time"
                   , Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Schema -> Referenced Schema) -> Schema -> Referenced Schema
forall a b. (a -> b) -> a -> b
$
                        Schema
forall a. Monoid a => a
mempty
                            Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiInteger
                            Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Scientific -> Identity (Maybe Scientific))
-> Schema -> Identity Schema
forall s a. HasMinimum s a => Lens' s a
Lens' Schema (Maybe Scientific)
minimum_ ((Maybe Scientific -> Identity (Maybe Scientific))
 -> Schema -> Identity Schema)
-> Scientific -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Scientific
0
                            Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Bool -> Identity (Maybe Bool)) -> Schema -> Identity Schema
forall s a. HasExclusiveMinimum s a => Lens' s a
Lens' Schema (Maybe Bool)
exclusiveMinimum ((Maybe Bool -> Identity (Maybe Bool))
 -> Schema -> Identity Schema)
-> Bool -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Bool
False
                   ]

instance FromHttpApiData TreeRevisionSelector where
    parseUrlPiece :: Text -> Either Text TreeRevisionSelector
parseUrlPiece Text
txt
        | Text -> Text
Text.toLower Text
txt Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"latest" = TreeRevisionSelector -> Either Text TreeRevisionSelector
forall a b. b -> Either a b
Right TreeRevisionSelector
Latest
        | Bool
otherwise =
            case String -> Maybe Int64
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack Text
txt) of
                Just Int64
i -> TreeRevisionSelector -> Either Text TreeRevisionSelector
forall a b. b -> Either a b
Right (TreeRevisionSelector -> Either Text TreeRevisionSelector)
-> TreeRevisionSelector -> Either Text TreeRevisionSelector
forall a b. (a -> b) -> a -> b
$ TreeRevisionID -> TreeRevisionSelector
Specific (TreeRevisionID -> TreeRevisionSelector)
-> TreeRevisionID -> TreeRevisionSelector
forall a b. (a -> b) -> a -> b
$ Int64 -> TreeRevisionID
TreeRevisionID Int64
i
                Maybe Int64
Nothing ->
                    case String -> Maybe UTCTime
parseFlexibleTime (Text -> String
Text.unpack Text
txt) of
                        Just UTCTime
ts -> TreeRevisionSelector -> Either Text TreeRevisionSelector
forall a b. b -> Either a b
Right (TreeRevisionSelector -> Either Text TreeRevisionSelector)
-> TreeRevisionSelector -> Either Text TreeRevisionSelector
forall a b. (a -> b) -> a -> b
$ UTCTime -> TreeRevisionSelector
LatestAsOf UTCTime
ts
                        Maybe UTCTime
Nothing -> Text -> Either Text TreeRevisionSelector
forall a b. a -> Either a b
Left (Text -> Either Text TreeRevisionSelector)
-> Text -> Either Text TreeRevisionSelector
forall a b. (a -> b) -> a -> b
$ Text
"Invalid TreeRevisionSelector: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txt

-- | Obtain id if selects a specific revision.
specificTreeRevision :: TreeRevisionSelector -> Maybe TreeRevisionID
specificTreeRevision :: TreeRevisionSelector -> Maybe TreeRevisionID
specificTreeRevision (Specific TreeRevisionID
id_) = TreeRevisionID -> Maybe TreeRevisionID
forall a. a -> Maybe a
Just TreeRevisionID
id_
specificTreeRevision TreeRevisionSelector
_ = Maybe TreeRevisionID
forall a. Maybe a
Nothing

-- | Obtain timestamp if selects @LatestAsOf@.
latestTreeRevisionAsOf :: TreeRevisionSelector -> Maybe UTCTime
latestTreeRevisionAsOf :: TreeRevisionSelector -> Maybe UTCTime
latestTreeRevisionAsOf (LatestAsOf UTCTime
ts) = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
ts
latestTreeRevisionAsOf TreeRevisionSelector
_ = Maybe UTCTime
forall a. Maybe a
Nothing

-- | An ID for a tree revision.
newtype TreeRevisionID = TreeRevisionID
    { TreeRevisionID -> Int64
unTreeRevisionID :: Int64
    }
    deriving (TreeRevisionID -> TreeRevisionID -> Bool
(TreeRevisionID -> TreeRevisionID -> Bool)
-> (TreeRevisionID -> TreeRevisionID -> Bool) -> Eq TreeRevisionID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TreeRevisionID -> TreeRevisionID -> Bool
== :: TreeRevisionID -> TreeRevisionID -> Bool
$c/= :: TreeRevisionID -> TreeRevisionID -> Bool
/= :: TreeRevisionID -> TreeRevisionID -> Bool
Eq)

instance ToJSON TreeRevisionID where
    toJSON :: TreeRevisionID -> Value
toJSON = Int64 -> Value
forall a. ToJSON a => a -> Value
toJSON (Int64 -> Value)
-> (TreeRevisionID -> Int64) -> TreeRevisionID -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeRevisionID -> Int64
unTreeRevisionID

instance FromJSON TreeRevisionID where
    parseJSON :: Value -> Parser TreeRevisionID
parseJSON = (Int64 -> TreeRevisionID) -> Parser Int64 -> Parser TreeRevisionID
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int64 -> TreeRevisionID
TreeRevisionID (Parser Int64 -> Parser TreeRevisionID)
-> (Value -> Parser Int64) -> Value -> Parser TreeRevisionID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser Int64
forall a. FromJSON a => Value -> Parser a
parseJSON

instance ToSchema TreeRevisionID where
    declareNamedSchema :: Proxy TreeRevisionID -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy TreeRevisionID
_ = Proxy Int64 -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy Int64
forall {k} (t :: k). Proxy t
Proxy :: Proxy Int64)

instance ToParamSchema TreeRevisionID where
    toParamSchema :: Proxy TreeRevisionID -> Schema
toParamSchema Proxy TreeRevisionID
_ =
        Schema
forall a. Monoid a => a
mempty
            Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiInteger
            Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Scientific -> Identity (Maybe Scientific))
-> Schema -> Identity Schema
forall s a. HasMinimum s a => Lens' s a
Lens' Schema (Maybe Scientific)
minimum_ ((Maybe Scientific -> Identity (Maybe Scientific))
 -> Schema -> Identity Schema)
-> Scientific -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Scientific
0
            Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Bool -> Identity (Maybe Bool)) -> Schema -> Identity Schema
forall s a. HasExclusiveMinimum s a => Lens' s a
Lens' Schema (Maybe Bool)
exclusiveMinimum ((Maybe Bool -> Identity (Maybe Bool))
 -> Schema -> Identity Schema)
-> Bool -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Bool
False

instance FromHttpApiData TreeRevisionID where
    parseUrlPiece :: Text -> Either Text TreeRevisionID
parseUrlPiece = (Int64 -> TreeRevisionID
TreeRevisionID (Int64 -> TreeRevisionID)
-> Either Text Int64 -> Either Text TreeRevisionID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Either Text Int64 -> Either Text TreeRevisionID)
-> (Text -> Either Text Int64)
-> Text
-> Either Text TreeRevisionID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text Int64
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece

-- | Contains metadata about a tree revision.
data TreeRevisionHeader = TreeRevisionHeader
    { TreeRevisionHeader -> TreeRevisionID
identifier :: TreeRevisionID
    , TreeRevisionHeader -> UTCTime
timestamp :: UTCTime
    , TreeRevisionHeader -> UserRef
author :: UserRef
    }
    deriving ((forall x. TreeRevisionHeader -> Rep TreeRevisionHeader x)
-> (forall x. Rep TreeRevisionHeader x -> TreeRevisionHeader)
-> Generic TreeRevisionHeader
forall x. Rep TreeRevisionHeader x -> TreeRevisionHeader
forall x. TreeRevisionHeader -> Rep TreeRevisionHeader x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TreeRevisionHeader -> Rep TreeRevisionHeader x
from :: forall x. TreeRevisionHeader -> Rep TreeRevisionHeader x
$cto :: forall x. Rep TreeRevisionHeader x -> TreeRevisionHeader
to :: forall x. Rep TreeRevisionHeader x -> TreeRevisionHeader
Generic)

instance ToJSON TreeRevisionHeader

instance FromJSON TreeRevisionHeader

instance ToSchema TreeRevisionHeader

-- | A tree revision.
data TreeRevision a
    = TreeRevision
        TreeRevisionHeader
        (Node a)

instance (ToJSON a) => ToJSON (TreeRevision a) where
    toJSON :: TreeRevision a -> Value
toJSON (TreeRevision TreeRevisionHeader
header Node a
root) =
        [Pair] -> Value
Aeson.object [Key
"header" Key -> TreeRevisionHeader -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= TreeRevisionHeader
header, Key
"root" Key -> Node a -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Node a
root]

instance (FromJSON a) => FromJSON (TreeRevision a) where
    parseJSON :: Value -> Parser (TreeRevision a)
parseJSON = String
-> (Object -> Parser (TreeRevision a))
-> Value
-> Parser (TreeRevision a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"TreeRevision" ((Object -> Parser (TreeRevision a))
 -> Value -> Parser (TreeRevision a))
-> (Object -> Parser (TreeRevision a))
-> Value
-> Parser (TreeRevision a)
forall a b. (a -> b) -> a -> b
$ \Object
v ->
        TreeRevisionHeader -> Node a -> TreeRevision a
forall a. TreeRevisionHeader -> Node a -> TreeRevision a
TreeRevision
            (TreeRevisionHeader -> Node a -> TreeRevision a)
-> Parser TreeRevisionHeader -> Parser (Node a -> TreeRevision a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser TreeRevisionHeader
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"header"
            Parser (Node a -> TreeRevision a)
-> Parser (Node a) -> Parser (TreeRevision a)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Node a)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"root"

instance (ToSchema a) => ToSchema (TreeRevision a) where
    declareNamedSchema :: Proxy (TreeRevision a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (TreeRevision a)
_ = do
        Referenced Schema
headerSchema <- Proxy TreeRevisionHeader
-> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
declareSchemaRef (Proxy TreeRevisionHeader
forall {k} (t :: k). Proxy t
Proxy :: Proxy TreeRevisionHeader)
        Referenced Schema
rootSchema <- Proxy (Node a) -> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
declareSchemaRef (Proxy (Node a)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (Node a))
        NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return
            (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
NamedSchema
                (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
withTypeName String
"TreeRevision")
            (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$ Schema
forall a. Monoid a => a
mempty
                Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiObject
                Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap Text (Referenced Schema)
 -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Identity Schema
forall s a. HasProperties s a => Lens' s a
Lens' Schema (InsOrdHashMap Text (Referenced Schema))
properties
                    ((InsOrdHashMap Text (Referenced Schema)
  -> Identity (InsOrdHashMap Text (Referenced Schema)))
 -> Schema -> Identity Schema)
-> InsOrdHashMap Text (Referenced Schema) -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(Text, Referenced Schema)]
-> InsOrdHashMap Text (Referenced Schema)
forall k v. (Eq k, Hashable k) => [(k, v)] -> InsOrdHashMap k v
InsOrd.fromList
                        [(Text
"header", Referenced Schema
headerSchema), (Text
"root", Referenced Schema
rootSchema)]
                Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ([Text] -> Identity [Text]) -> Schema -> Identity Schema
forall s a. HasRequired s a => Lens' s a
Lens' Schema [Text]
required (([Text] -> Identity [Text]) -> Schema -> Identity Schema)
-> [Text] -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Text
"header", Text
"root"]
      where
        withTypeName :: String -> Text
withTypeName String
s = String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typeName
        typeName :: String
typeName = TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)

-- | Sequence of revisions for a document tree.
data TreeRevisionHistory
    = TreeRevisionHistory
        DocumentID
        [TreeRevisionHeader]

instance ToJSON TreeRevisionHistory where
    toJSON :: TreeRevisionHistory -> Value
toJSON (TreeRevisionHistory DocumentID
docID [TreeRevisionHeader]
history) =
        [Pair] -> Value
Aeson.object [Key
"document" Key -> DocumentID -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= DocumentID
docID, Key
"history" Key -> [TreeRevisionHeader] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [TreeRevisionHeader]
history]

instance FromJSON TreeRevisionHistory where
    parseJSON :: Value -> Parser TreeRevisionHistory
parseJSON = String
-> (Object -> Parser TreeRevisionHistory)
-> Value
-> Parser TreeRevisionHistory
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"TreeRevisionHistory" ((Object -> Parser TreeRevisionHistory)
 -> Value -> Parser TreeRevisionHistory)
-> (Object -> Parser TreeRevisionHistory)
-> Value
-> Parser TreeRevisionHistory
forall a b. (a -> b) -> a -> b
$ \Object
v ->
        DocumentID -> [TreeRevisionHeader] -> TreeRevisionHistory
TreeRevisionHistory
            (DocumentID -> [TreeRevisionHeader] -> TreeRevisionHistory)
-> Parser DocumentID
-> Parser ([TreeRevisionHeader] -> TreeRevisionHistory)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser DocumentID
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"document"
            Parser ([TreeRevisionHeader] -> TreeRevisionHistory)
-> Parser [TreeRevisionHeader] -> Parser TreeRevisionHistory
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser [TreeRevisionHeader]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"history"

instance ToSchema TreeRevisionHistory where
    declareNamedSchema :: Proxy TreeRevisionHistory
-> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy TreeRevisionHistory
_ = do
        Referenced Schema
documentSchema <- Proxy DocumentID
-> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
declareSchemaRef (Proxy DocumentID
forall {k} (t :: k). Proxy t
Proxy :: Proxy DocumentID)
        Referenced Schema
historySchema <- Proxy [TreeRevisionHeader]
-> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
declareSchemaRef (Proxy [TreeRevisionHeader]
forall {k} (t :: k). Proxy t
Proxy :: Proxy [TreeRevisionHeader])
        NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$
            Maybe Text -> Schema -> NamedSchema
NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"TreeRevisionHistory") (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$
                Schema
forall a. Monoid a => a
mempty
                    Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiObject
                    Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap Text (Referenced Schema)
 -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Identity Schema
forall s a. HasProperties s a => Lens' s a
Lens' Schema (InsOrdHashMap Text (Referenced Schema))
properties
                        ((InsOrdHashMap Text (Referenced Schema)
  -> Identity (InsOrdHashMap Text (Referenced Schema)))
 -> Schema -> Identity Schema)
-> InsOrdHashMap Text (Referenced Schema) -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(Text, Referenced Schema)]
-> InsOrdHashMap Text (Referenced Schema)
forall k v. (Eq k, Hashable k) => [(k, v)] -> InsOrdHashMap k v
InsOrd.fromList
                            [ (Text
"document", Referenced Schema
documentSchema)
                            , (Text
"history", Referenced Schema
historySchema)
                            ]
                    Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ([Text] -> Identity [Text]) -> Schema -> Identity Schema
forall s a. HasRequired s a => Lens' s a
Lens' Schema [Text]
required (([Text] -> Identity [Text]) -> Schema -> Identity Schema)
-> [Text] -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Text
"document", Text
"history"]

mapRoot :: (Node a -> Node b) -> TreeRevision a -> TreeRevision b
mapRoot :: forall a b. (Node a -> Node b) -> TreeRevision a -> TreeRevision b
mapRoot Node a -> Node b
f (TreeRevision TreeRevisionHeader
header Node a
root) = TreeRevisionHeader -> Node b -> TreeRevision b
forall a. TreeRevisionHeader -> Node a -> TreeRevision a
TreeRevision TreeRevisionHeader
header (Node b -> TreeRevision b) -> Node b -> TreeRevision b
forall a b. (a -> b) -> a -> b
$ Node a -> Node b
f Node a
root

replaceRoot :: Node b -> TreeRevision a -> TreeRevision b
replaceRoot :: forall b a. Node b -> TreeRevision a -> TreeRevision b
replaceRoot Node b
new = (Node a -> Node b) -> TreeRevision a -> TreeRevision b
forall a b. (Node a -> Node b) -> TreeRevision a -> TreeRevision b
mapRoot ((Node a -> Node b) -> TreeRevision a -> TreeRevision b)
-> (Node a -> Node b) -> TreeRevision a -> TreeRevision b
forall a b. (a -> b) -> a -> b
$ Node b -> Node a -> Node b
forall a b. a -> b -> a
const Node b
new

mapMRoot
    :: (Monad m)
    => (Node a -> m (Node b))
    -> TreeRevision a
    -> m (TreeRevision b)
mapMRoot :: forall (m :: * -> *) a b.
Monad m =>
(Node a -> m (Node b)) -> TreeRevision a -> m (TreeRevision b)
mapMRoot Node a -> m (Node b)
f (TreeRevision TreeRevisionHeader
header Node a
root) = Node a -> m (Node b)
f Node a
root m (Node b) -> (Node b -> TreeRevision b) -> m (TreeRevision b)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> TreeRevisionHeader -> Node b -> TreeRevision b
forall a. TreeRevisionHeader -> Node a -> TreeRevision a
TreeRevision TreeRevisionHeader
header

instance Functor TreeRevision where
    fmap :: forall a b. (a -> b) -> TreeRevision a -> TreeRevision b
fmap a -> b
f (TreeRevision TreeRevisionHeader
header Node a
root) = TreeRevisionHeader -> Node b -> TreeRevision b
forall a. TreeRevisionHeader -> Node a -> TreeRevision a
TreeRevision TreeRevisionHeader
header (Node b -> TreeRevision b) -> Node b -> TreeRevision b
forall a b. (a -> b) -> a -> b
$ a -> b
f (a -> b) -> Node a -> Node b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node a
root

-- | Takes a tree revision and emplaces concrecte text revisions.
-- | The text revisions are obtained via the specified getter function.
withTextRevisions
    :: (Monad m)
    => (TextElementID -> m (Maybe TextRevision))
    -- ^ (potentially effectful) function for obtaining a text revision
    -> TreeRevision TextElement
    -- ^ document structre tree revision
    -> m (TreeRevision TextElementRevision)
    -- ^ document structre tree revision with concrete text revision
withTextRevisions :: forall (m :: * -> *).
Monad m =>
(TextElementID -> m (Maybe TextRevision))
-> TreeRevision TextElement -> m (TreeRevision TextElementRevision)
withTextRevisions TextElementID -> m (Maybe TextRevision)
getTextRevision = (Node TextElement -> m (Node TextElementRevision))
-> TreeRevision TextElement -> m (TreeRevision TextElementRevision)
forall (m :: * -> *) a b.
Monad m =>
(Node a -> m (Node b)) -> TreeRevision a -> m (TreeRevision b)
mapMRoot ((TextElementID -> m (Maybe TextRevision))
-> Node TextElement -> m (Node TextElementRevision)
forall (m :: * -> *).
Monad m =>
(TextElementID -> m (Maybe TextRevision))
-> Node TextElement -> m (Node TextElementRevision)
Tree.withTextRevisions TextElementID -> m (Maybe TextRevision)
getTextRevision)

newTreeRevision
    :: (Monad m)
    => (DocumentID -> m (TextElementID -> Bool))
    -- ^ for a given document, checks if a text element belongs to this document
    -> (UserID -> DocumentID -> Node TextElementID -> m (TreeRevision TextElementID))
    -- ^ create a new tree revision
    -> UserID
    -- ^ authors user id
    -> DocumentID
    -- ^ which document the revision belongs to
    -> Node TextElementID
    -- ^ the root node of the revision
    -> m (TreeRevision TextElementID)
    -- ^ newly created revision
newTreeRevision :: forall (m :: * -> *).
Monad m =>
(DocumentID -> m (TextElementID -> Bool))
-> (UserID
    -> DocumentID
    -> Node TextElementID
    -> m (TreeRevision TextElementID))
-> UserID
-> DocumentID
-> Node TextElementID
-> m (TreeRevision TextElementID)
newTreeRevision
    DocumentID -> m (TextElementID -> Bool)
isTextElementInDocument
    UserID
-> DocumentID
-> Node TextElementID
-> m (TreeRevision TextElementID)
createRevision
    UserID
authorID
    DocumentID
docID
    Node TextElementID
rootNode = do
        TextElementID -> Bool
isTextElementInDocument' <- DocumentID -> m (TextElementID -> Bool)
isTextElementInDocument DocumentID
docID
        let allTextElementsBelongToDocument :: Bool
allTextElementsBelongToDocument =
                (TextElementID -> Bool) -> Node TextElementID -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TextElementID -> Bool
isTextElementInDocument' Node TextElementID
rootNode
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
allTextElementsBelongToDocument (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            String -> m ()
forall a. HasCallStack => String -> a
error String
"Not all referenced text elements belong to the document."
        UserID
-> DocumentID
-> Node TextElementID
-> m (TreeRevision TextElementID)
createRevision UserID
authorID DocumentID
docID Node TextElementID
rootNode