module Database.DynamoDB.TH (
mkTableDefs
, TableConfig(..)
, tableConfig
, defaultTranslate
, deriveCollection
, deriveEncodable
, RangeType(..)
) where
import Control.Lens (ix, over, (.~), (^.), _1, view, (^..))
import Control.Monad (forM_, unless, when)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Writer.Lazy (WriterT, execWriterT, tell)
import Data.Bool (bool)
import Data.Char (toUpper)
import Data.Function ((&))
import Data.Monoid ((<>))
import qualified Data.Text as T
import Data.HashMap.Strict (HashMap)
import Generics.SOP
import Generics.SOP.TH (deriveGenericOnly)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (Name (..), OccName (..))
import Network.AWS.DynamoDB.Types (attributeValue, avM, ProvisionedThroughput, StreamViewType)
import Network.AWS (MonadAWS)
import Database.DynamoDB.Class
import Database.DynamoDB.Migration (runMigration)
import Database.DynamoDB.Types
import Database.DynamoDB.Internal
import Database.DynamoDB.THLens
import Database.DynamoDB.THContains
import Database.DynamoDB.THConvert
data TableConfig = TableConfig {
tableSetup :: (Name, RangeType, String)
, globalIndexes :: [(Name, RangeType, String)]
, localIndexes :: [(Name, String)]
, translateField :: String -> String
, buildLens :: Bool
}
tableConfig ::
String
-> (Name, RangeType)
-> [(Name, RangeType)]
-> [Name]
-> TableConfig
tableConfig prefix (table, tbltype) globidx locidx =
TableConfig {
tableSetup = (table, tbltype, prefix ++ nameToStr table)
, globalIndexes = map (\(n,r) -> (n, r, prefix ++ nameToStr n)) globidx
, localIndexes = map (\n -> (n, prefix ++ nameToStr n)) locidx
, translateField = defaultTranslate
, buildLens = True
}
where
nameToStr (Name (OccName name) _) = name
defaultTranslate :: String -> String
defaultTranslate = translate
where
translate ('_':rest) = rest
translate name
| '_' `elem` name = drop 1 $ dropWhile (/= '_') name
| otherwise = name
mkTableDefs ::
String
-> TableConfig
-> Q [Dec]
mkTableDefs migname TableConfig{..} =
execWriterT $ do
let (table, tblrange, tblname) = tableSetup
tblFieldNames <- getFieldNames table translateField
buildColData tblFieldNames
genBaseCollection table tblrange tblname Nothing translateField False
let tblHashName = fst (head tblFieldNames)
forM_ localIndexes $ \(idx, _) -> do
idxHashName <- (fst . head) <$> getFieldNames idx translateField
when (idxHashName /= tblHashName) $
fail ("Hash key " <> show idxHashName <> " in local index " <> show idx
<> " is not equal to table hash key " <> show tblHashName)
let allindexes = map (\(idx, idxrange, idxname) -> (idx, idxrange, idxname, False)) globalIndexes
++ map (\(idx,name) -> (idx, WithRange, name, True)) localIndexes
forM_ allindexes $ \(idx, idxrange, idxname, islocal) -> do
genBaseCollection idx idxrange idxname (Just table) translateField islocal
instfields <- getFieldNames idx translateField
let pkeytable = [True | _ <- [1..(pkeySize idxrange)] ] ++ repeat False
forM_ (zip instfields pkeytable) $ \((fieldname, ltype), isKey) ->
case lookup fieldname tblFieldNames of
Just (AppT (ConT mbtype) inptype)
| mbtype == ''Maybe && inptype == ltype && isKey -> return ()
Just ptype
| ltype /= ptype -> fail $ "Record '" <> fieldname <> "' form index " <> show idx <> " has different type from table " <> show table
<> ": " <> show ltype <> " /= " <> show ptype
| otherwise -> return ()
Nothing ->
fail ("Record '" <> fieldname <> "' from index " <> show idx <> " is not in present in table " <> show table)
migfunc <- lift $ mkMigrationFunc migname table (map (view _1) globalIndexes) (map (view _1) localIndexes)
tell migfunc
when buildLens $
createPolyLenses translateField table (map (view _1) allindexes)
let pkey = map fst $ take (pkeySize tblrange) tblFieldNames
forM_ (table : (allindexes ^.. traverse . _1)) $
createContainsTableKey translateField table pkey
unless (null allindexes) $
createTableConversions translateField table (allindexes ^.. traverse . _1)
pkeySize :: RangeType -> Int
pkeySize WithRange = 2
pkeySize NoRange = 1
genBaseCollection :: Name -> RangeType -> String -> Maybe Name -> (String -> String) -> Bool -> WriterT [Dec] Q ()
genBaseCollection coll collrange tblname mparent translate isLocal = do
tblFieldNames <- getFieldNames coll translate
let fieldNames = map fst tblFieldNames
let fieldList = listE (map (appE (varE 'T.pack) . litE . StringL) fieldNames)
primaryList' <- case (collrange, fieldNames) of
(NoRange, hashname:_) -> return [hashname]
(WithRange, h:r:_)-> return [h,r]
_ -> fail "Table must have at least 1/2 fields based on range key"
let primaryList = listE (map (appE (varE 'T.pack) . litE . StringL) primaryList')
let tbltype = maybe (promotedT 'IsTable) (const $ promotedT 'IsIndex) mparent
lift (deriveGenericOnly coll) >>= tell
lift [d|
instance DynamoCollection $(conT coll) $(conT $ mrange collrange) $(tbltype) where
allFieldNames _ = $(fieldList)
primaryFields _ = $(primaryList)
|] >>= tell
case mparent of
Nothing -> do
mkCollectionProxy True
lift [d|
instance DynamoTable $(conT coll) $(conT $ mrange collrange) where
tableName _ = $(appE (varE 'T.pack) (litE (StringL tblname)))
|] >>= tell
Just parent -> do
mkCollectionProxy False
lift [d|
instance DynamoIndex $(conT coll) $(conT parent) $(conT $ mrange collrange) where
indexName _ = $(appE (varE 'T.pack) (litE (StringL tblname)))
indexIsLocal _ = $(conE (if isLocal then 'True else 'False))
|] >>= tell
let constrNames = mkConstrNames tblFieldNames
forM_ (drop (pkeySize collrange) constrNames) $ \constr ->
lift [d|
instance InCollection $(conT constr) $(conT coll) 'FullPath
|] >>= tell
where
mrange WithRange = 'WithRange
mrange NoRange = 'NoRange
mkCollectionProxy istable = do
let proxyName = mkName (bool "i" "t" istable <> nameBase coll)
say $ SigD proxyName (AppT (ConT ''Proxy) (ConT coll))
say $ ValD (VarP proxyName) (NormalB (ConE 'Proxy)) []
toConstrName :: String -> String
toConstrName = ("P_" <>) . over (ix 0) toUpper
mkConstrNames :: [(String,a)] -> [Name]
mkConstrNames = map (mkName . toConstrName . fst)
buildColData :: [(String, Type)] -> WriterT [Dec] Q ()
buildColData fieldlist = do
let constrNames = mkConstrNames fieldlist
forM_ (zip fieldlist constrNames) $ \((fieldname, ltype), constr) -> do
let pat = mkName (fieldname <> "'")
#if __GLASGOW_HASKELL__ >= 800
say $ DataD [] constr [] Nothing [] []
#else
say $ DataD [] constr [] [] []
#endif
lift [d|
instance ColumnInfo $(conT constr) where
columnName _ = T.pack fieldname
|] >>= tell
say $ SigD pat (AppT (AppT (AppT (ConT ''Column) ltype) (ConT 'TypColumn)) (ConT constr))
say $ ValD (VarP pat) (NormalB (VarE 'mkColumn)) []
deriveCollection :: Name -> (String -> String) -> Q [Dec]
deriveCollection table translate =
execWriterT $ do
lift (deriveGenericOnly table) >>= tell
tblFieldNames <- getFieldNames table translate
buildColData tblFieldNames
deriveEncodable' table translate
deriveEncodable :: Name -> (String -> String) -> Q [Dec]
deriveEncodable name trans = execWriterT (deriveEncodable' name trans)
deriveEncodable' :: Name -> (String -> String) -> WriterT [Dec] Q ()
deriveEncodable' table translate = do
tblFieldNames <- getFieldNames table translate
let fieldList = listE (map (appE (varE 'T.pack) . litE . StringL . fst) tblFieldNames)
lift [d|
instance DynamoEncodable $(conT table) where
dEncode val = Just (attributeValue & avM .~ gsEncodeG $(fieldList) val)
dDecode (Just attr) = gsDecodeG $(fieldList) (attr ^. avM)
dDecode Nothing = Nothing
|] >>= tell
let constrs = mkConstrNames tblFieldNames
forM_ constrs $ \constr ->
lift [d|
instance InCollection $(conT constr) $(conT table) 'NestedPath
|] >>= tell
mkMigrationFunc :: String -> Name -> [Name] -> [Name] -> Q [Dec]
mkMigrationFunc name table globindexes locindexes = do
let glMap = ListE (map glIdxTemplate globindexes)
locMap = ListE (map locIdxTemplate locindexes)
let funcname = mkName name
m <- newName "m"
let signature = SigD funcname (ForallT [PlainTV m] [AppT (ConT ''MonadAWS) (VarT m)]
(AppT (AppT ArrowT (AppT (AppT (ConT ''HashMap) (ConT ''T.Text))
(ConT ''ProvisionedThroughput)))
(AppT (AppT ArrowT (AppT (ConT ''Maybe) (ConT ''StreamViewType)))
(AppT (VarT m) (TupleT 0)))))
return [signature, ValD (VarP funcname) (NormalB (AppE (AppE (AppE (VarE 'runMigration)
(SigE (ConE 'Proxy)
(AppT (ConT ''Proxy)
(ConT table)))) glMap) locMap)) []]
where
glIdxTemplate idx = AppE (VarE 'createGlobalIndex) (SigE (ConE 'Proxy) (AppT (ConT ''Proxy) (ConT idx)))
locIdxTemplate idx = AppE (VarE 'createLocalIndex) (SigE (ConE 'Proxy) (AppT (ConT ''Proxy) (ConT idx)))