module Avers.Types where
import Control.Applicative
import Control.Monad.Except
import Control.Monad.State
import Control.Concurrent.STM
import Data.Time.Clock
import Data.String
import Data.ByteString.Lazy (ByteString)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Map (Map)
import qualified Data.Map as M
import Data.Monoid
import Data.Char
import Data.Attoparsec.Text
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
import Data.Aeson (Value(String))
import Data.Aeson.Types (parseEither)
import qualified Database.RethinkDB as R
import Database.RethinkDB.TH
import Data.Pool
import Avers.TH
import Avers.Index
import Avers.Metrics.Measurements
class Pk a where
toPk :: a -> Text
instance Pk Text where
toPk = id
newtype Path = Path { unPath :: Text }
deriving (Eq, Ord, Show)
instance IsString Path where
fromString = Path . T.pack
instance ToJSON Path where
toJSON = toJSON . unPath
instance FromJSON Path where
parseJSON (String s) = return $ Path s
parseJSON _ = fail "Path"
instance R.FromDatum Path where
parseDatum (R.String s) = return $ Path s
parseDatum _ = fail "Path"
instance R.ToDatum Path where
toDatum = R.toDatum . unPath
newtype ObjId = ObjId { unObjId :: Text }
deriving (Eq, Ord, Show)
instance Pk ObjId where
toPk = unObjId
instance ToJSON ObjId where
toJSON = toJSON . unObjId
instance FromJSON ObjId where
parseJSON x = ObjId <$> parseJSON x
instance R.FromDatum ObjId where
parseDatum x = ObjId <$> R.parseDatum x
instance R.ToDatum ObjId where
toDatum = R.toDatum . unObjId
rootObjId :: ObjId
rootObjId = ObjId ""
newtype RevId = RevId { unRevId :: Int }
deriving (Eq, Ord, Show)
instance Enum RevId where
succ (RevId x) = RevId (succ x)
pred (RevId x) = RevId (pred x)
toEnum = RevId
fromEnum = unRevId
instance Pk RevId where
toPk = T.pack . show . unRevId
instance ToJSON RevId where
toJSON = toJSON . unRevId
instance FromJSON RevId where
parseJSON x = RevId <$> parseJSON x
instance R.FromDatum RevId where
parseDatum x = RevId <$> R.parseDatum x
instance R.ToDatum RevId where
toDatum = R.toDatum . unRevId
zeroRevId :: RevId
zeroRevId = RevId 0
data ObjectId
= BaseObjectId !ObjId
| ReleaseObjectId !ObjId !RevId
| AuthorizationObjectId !ObjId
deriving (Eq, Ord, Show)
instance Pk ObjectId where
toPk (BaseObjectId objId) = toPk objId
toPk (ReleaseObjectId objId revId) = toPk objId <> "/release/" <> toPk revId
toPk (AuthorizationObjectId objId) = toPk objId <> "/authorization"
instance ToJSON ObjectId where
toJSON = toJSON . toPk
instance FromJSON ObjectId where
parseJSON (String x) = either fail return $ parseOnly objectIdParser x
parseJSON _ = fail "ObjectId"
instance R.FromDatum ObjectId where
parseDatum (R.String x) = either fail return $ parseOnly objectIdParser x
parseDatum _ = fail "ObjectId"
instance R.ToDatum ObjectId where
toDatum = R.toDatum . toPk
objectIdParser :: Parser ObjectId
objectIdParser = (releaseObjectId <|> authorizationObjectId <|> baseObjectId) <* endOfInput
where
objId = ObjId <$> takeWhile1 isAlphaNum
revId = RevId <$> decimal
baseObjectId = BaseObjectId
<$> objId
releaseObjectId = ReleaseObjectId
<$> objId
<* string "/release/"
<*> revId
authorizationObjectId = AuthorizationObjectId
<$> objId
<* string "/authorization"
parseObjectId :: Text -> Maybe ObjectId
parseObjectId text = case parseOnly objectIdParser text of
Left _ -> Nothing
Right v -> Just v
objectIdBase :: ObjectId -> ObjId
objectIdBase (BaseObjectId objId ) = objId
objectIdBase (ReleaseObjectId objId _) = objId
objectIdBase (AuthorizationObjectId objId ) = objId
data Operation
= Set
{ opPath :: !Path
, opValue :: !(Maybe Value)
}
| Splice
{ opPath :: !Path
, opIndex :: !Int
, opRemove :: !Int
, opInsert :: ![ Value ]
}
deriving (Eq, Show)
$(deriveEncoding (deriveJSONOptions "op"){
omitNothingFields = True,
sumEncoding = TaggedObject "type" "content"
} ''Operation)
data PatchError
= UnknownPatchError !Text
deriving (Show)
type PatchM a = Either PatchError a
data Object = Object
{ objectId :: !ObjId
, objectType :: !Text
, objectCreatedAt :: !UTCTime
, objectCreatedBy :: !ObjId
, objectDeleted :: !(Maybe Bool)
} deriving (Show)
instance Pk Object where
toPk = toPk . objectId
$(deriveEncoding (deriveJSONOptions "object") ''Object)
data Patch = Patch
{ patchObjectId :: !ObjectId
, patchRevisionId :: !RevId
, patchAuthorId :: !ObjId
, patchCreatedAt :: !UTCTime
, patchOperation :: !Operation
} deriving (Show)
instance Pk Patch where
toPk Patch{..} = toPk patchObjectId <> "@" <> toPk patchRevisionId
$(deriveEncoding (deriveJSONOptions "patch") ''Patch)
data Snapshot = Snapshot
{ snapshotObjectId :: !ObjectId
, snapshotRevisionId :: !RevId
, snapshotContent :: !Value
} deriving (Show)
instance Pk Snapshot where
toPk Snapshot{..} = toPk snapshotObjectId <> "@" <> toPk snapshotRevisionId
$(deriveEncoding (deriveJSONOptions "snapshot") ''Snapshot)
data Release = Release
instance ToJSON Release where
toJSON = const Aeson.emptyObject
instance FromJSON Release where
parseJSON (Aeson.Object _) = return Release
parseJSON _ = fail "Release"
newtype SecretId = SecretId { unSecretId :: Text }
deriving (Show)
instance Pk SecretId where
toPk = unSecretId
instance ToJSON SecretId where
toJSON = toJSON . unSecretId
instance FromJSON SecretId where
parseJSON x = SecretId <$> parseJSON x
instance R.FromDatum SecretId where
parseDatum x = SecretId <$> R.parseDatum x
instance R.ToDatum SecretId where
toDatum = R.toDatum . unSecretId
data Secret = Secret
{ secretId :: !SecretId
, secretValue :: !Text
}
instance Pk Secret where
toPk = toPk . secretId
$(deriveEncoding (deriveJSONOptions "secret") ''Secret)
newtype BlobId = BlobId { unBlobId :: Text }
deriving (Show)
instance Pk BlobId where
toPk = unBlobId
instance ToJSON BlobId where
toJSON = toJSON . unBlobId
instance FromJSON BlobId where
parseJSON x = BlobId <$> parseJSON x
instance R.FromDatum BlobId where
parseDatum x = BlobId <$> R.parseDatum x
instance R.ToDatum BlobId where
toDatum = R.toDatum . unBlobId
data Blob = Blob
{ blobId :: !BlobId
, blobSize :: !Int
, blobContentType :: !Text
} deriving (Show)
instance Pk Blob where
toPk = toPk . blobId
$(deriveEncoding (deriveJSONOptions "blob") ''Blob)
newtype SessionId = SessionId { unSessionId :: Text }
instance Pk SessionId where
toPk = unSessionId
instance ToJSON SessionId where
toJSON = toJSON . unSessionId
instance FromJSON SessionId where
parseJSON x = SessionId <$> parseJSON x
instance R.FromDatum SessionId where
parseDatum x = SessionId <$> R.parseDatum x
instance R.ToDatum SessionId where
toDatum = R.toDatum . unSessionId
data Session = Session
{ sessionId :: !SessionId
, sessionObjId :: !ObjId
, sessionCreatedAt :: !UTCTime
, sessionLastAccessedAt :: !UTCTime
}
instance Pk Session where
toPk Session{..} = toPk sessionId
$(deriveEncoding (deriveJSONOptions "session") ''Session)
data AversError
= InternalError !AversError
| DatabaseError !Text
| PatchError !PatchError
| ParseError !Value !Text
| UnknownObjectType !Text
| ObjectNotFound !ObjId
| DocumentNotFound !Text
| AversError !Text
| NotAuthorized
deriving (Show)
internalError :: AversError -> Avers a
internalError = throwError . InternalError
internal :: Avers a -> Avers a
internal m = m `catchError` internalError
databaseError :: Text -> Avers a
databaseError = throwError . DatabaseError
patchError :: PatchError -> Avers a
patchError = throwError . PatchError
parseError :: (MonadError AversError m) => Value -> Text -> m a
parseError value text = throwError $ ParseError value text
documentNotFound :: Text -> Avers a
documentNotFound = throwError . DocumentNotFound
strErr :: String -> Avers a
strErr = throwError . AversError . T.pack
data ObjectType a = ObjectType
{ otType :: !Text
, otId :: Avers ObjId
, otViews :: [SomeView a]
}
data SomeObjectType where
SomeObjectType :: (R.ToDatum a, R.FromDatum a, FromJSON a, ToJSON a)
=> ObjectType a -> SomeObjectType
parseValueAs :: (FromJSON a) => ObjectType a -> Value -> Either AversError a
parseValueAs ObjectType{..} value = case parseEither parseJSON value of
Left e -> parseError value (T.pack $ show e)
Right x -> return x
data AversConfig = AversConfig
{ databaseHost :: !Text
, databaseName :: !Text
, putBlob :: BlobId -> Text -> ByteString -> IO ()
, objectTypes :: ![SomeObjectType]
, emitMeasurement :: Measurement -> Double -> IO ()
}
data AversState = AversState
{ config :: !AversConfig
, databaseHandlePool :: !(Pool R.Handle)
, recentRevisionCache :: !(TVar (Map ObjectId RevId))
}
newDatabaseHandlePool :: AversConfig -> IO (Pool R.Handle)
newDatabaseHandlePool AversConfig{..} =
createPool create destroy numStripes idleTime maxResources
where
create = do
putStrLn $ mconcat
[ "Creating a new RethinkDB handle to "
, T.unpack databaseHost
, ":28015"
, " database "
, T.unpack databaseName
]
R.newHandle databaseHost 28015 Nothing (R.Database (R.lift databaseName))
destroy handle = do
putStrLn "Closing RethinkDB handle"
R.close handle
numStripes = 1
idleTime = fromIntegral $ (60 * 60 :: Int)
maxResources = 10
newState :: AversConfig -> IO AversState
newState config = do
AversState
<$> pure config
<*> newDatabaseHandlePool config
<*> newTVarIO M.empty
newtype Avers a = Avers
{ runAvers :: StateT AversState (ExceptT AversError IO) a
} deriving (Functor, Applicative, Monad, MonadIO, MonadError AversError, MonadState AversState)
class (Monad m) => MonadAvers m where
liftAvers :: Avers a -> m a
instance MonadAvers Avers where
liftAvers = id
instance MonadAvers m => MonadAvers (StateT s m) where
liftAvers = lift . liftAvers
evalAvers :: AversState -> Avers a -> IO (Either AversError a)
evalAvers h m = runExceptT $ evalStateT (runAvers m) h
data View obj a = View
{ viewName :: Text
, viewParser :: R.Datum -> Either AversError a
, viewObjectTransformer :: obj -> Avers (Maybe a)
, viewIndices :: [SomeIndex]
}
data SomeView obj where
SomeView :: (R.ToDatum a, R.FromDatum a, FromJSON obj, ToJSON a)
=> View obj a -> SomeView obj