diff --git a/Database/Persist.hs b/Database/Persist.hs new file mode 100644 --- /dev/null +++ b/Database/Persist.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PackageImports #-} + +-- | This defines the API for performing database actions. There are two levels +-- to this API: dealing with fields, and dealing with entities. In SQL, a field +-- corresponds to a column, and should be a single, non-composite value. An +-- entity corresponds to a SQL table. In other words: An entity is a +-- collection of fields. +module Database.Persist + ( -- * Fields + PersistValue (..) + , SqlType (..) + , PersistField (..) + -- * Entities + , PersistEntity (..) + ) where + +import Data.Time (Day, TimeOfDay, UTCTime) +import Data.ByteString.Char8 (ByteString, unpack) +import qualified Data.ByteString.UTF8 as BSU +import Control.Applicative +import Data.Typeable (Typeable) +import Data.Int (Int64) +import Text.Hamlet +import qualified Data.Text as T +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO) + +-- | A raw value which can be stored in any backend and can be marshalled to +-- and from a 'PersistField'. +data PersistValue = PersistString String + | PersistByteString ByteString + | PersistInt64 Int64 + | PersistDouble Double + | PersistBool Bool + | PersistDay Day + | PersistTimeOfDay TimeOfDay + | PersistUTCTime UTCTime + | PersistNull + deriving (Show, Read, Eq, Typeable) + +-- | A SQL data type. Naming attempts to reflect the underlying Haskell +-- datatypes, eg SqlString instead of SqlVarchar. Different SQL databases may +-- have different translations for these types. +data SqlType = SqlString + | SqlInteger + | SqlReal + | SqlBool + | SqlDay + | SqlTime + | SqlDayTime + | SqlBlob + deriving (Show, Read, Eq, Typeable) + +-- | A value which can be marshalled to and from a 'PersistValue'. +class PersistField a where + toPersistValue :: a -> PersistValue + fromPersistValue :: PersistValue -> Either String a + sqlType :: a -> SqlType + isNullable :: a -> Bool + isNullable _ = False + +instance PersistField String where + toPersistValue = PersistString + fromPersistValue (PersistString s) = Right s + fromPersistValue (PersistByteString bs) = Right $ BSU.toString bs + fromPersistValue (PersistInt64 i) = Right $ show i + fromPersistValue (PersistDouble d) = Right $ show d + fromPersistValue (PersistDay d) = Right $ show d + fromPersistValue (PersistTimeOfDay d) = Right $ show d + fromPersistValue (PersistUTCTime d) = Right $ show d + fromPersistValue PersistNull = Left "Unexpected null" + fromPersistValue (PersistBool b) = Right $ show b + sqlType _ = SqlString + +instance PersistField ByteString where + toPersistValue = PersistByteString + fromPersistValue (PersistByteString bs) = Right bs + fromPersistValue x = BSU.fromString <$> fromPersistValue x + sqlType _ = SqlBlob + +instance PersistField T.Text where + toPersistValue = PersistString . T.unpack + fromPersistValue = fmap T.pack . fromPersistValue + sqlType _ = SqlString + +instance PersistField (Html ()) where + toPersistValue = PersistByteString . S.concat . L.toChunks . renderHtml + fromPersistValue = fmap unsafeByteString . fromPersistValue + sqlType _ = SqlString + +instance PersistField Int where + toPersistValue = PersistInt64 . fromIntegral + fromPersistValue (PersistInt64 i) = Right $ fromIntegral i + fromPersistValue x = Left $ "Expected Integer, received: " ++ show x + sqlType _ = SqlInteger + +instance PersistField Int64 where + toPersistValue = PersistInt64 . fromIntegral + fromPersistValue (PersistInt64 i) = Right $ fromIntegral i + fromPersistValue x = Left $ "Expected Integer, received: " ++ show x + sqlType _ = SqlInteger + +instance PersistField Double where + toPersistValue = PersistDouble + fromPersistValue (PersistDouble d) = Right d + fromPersistValue x = Left $ "Expected Double, received: " ++ show x + sqlType _ = SqlReal + +instance PersistField Bool where + toPersistValue = PersistBool + fromPersistValue (PersistBool b) = Right b + fromPersistValue (PersistInt64 i) = Right $ i /= 0 + fromPersistValue x = Left $ "Expected Bool, received: " ++ show x + sqlType _ = SqlBool + +instance PersistField Day where + toPersistValue = PersistDay + fromPersistValue (PersistDay d) = Right d + fromPersistValue x@(PersistString s) = + case reads s of + (d, _):_ -> Right d + _ -> Left $ "Expected Day, received " ++ show x + fromPersistValue x@(PersistByteString s) = + case reads $ unpack s of + (d, _):_ -> Right d + _ -> Left $ "Expected Day, received " ++ show x + fromPersistValue x = Left $ "Expected Day, received: " ++ show x + sqlType _ = SqlDay + +instance PersistField TimeOfDay where + toPersistValue = PersistTimeOfDay + fromPersistValue (PersistTimeOfDay d) = Right d + fromPersistValue x@(PersistString s) = + case reads s of + (d, _):_ -> Right d + _ -> Left $ "Expected TimeOfDay, received " ++ show x + fromPersistValue x@(PersistByteString s) = + case reads $ unpack s of + (d, _):_ -> Right d + _ -> Left $ "Expected TimeOfDay, received " ++ show x + fromPersistValue x = Left $ "Expected TimeOfDay, received: " ++ show x + sqlType _ = SqlTime + +instance PersistField UTCTime where + toPersistValue = PersistUTCTime + fromPersistValue (PersistUTCTime d) = Right d + fromPersistValue x@(PersistString s) = + case reads s of + (d, _):_ -> Right d + _ -> Left $ "Expected UTCTime, received " ++ show x + fromPersistValue x@(PersistByteString s) = + case reads $ unpack s of + (d, _):_ -> Right d + _ -> Left $ "Expected UTCTime, received " ++ show x + fromPersistValue x = Left $ "Expected UTCTime, received: " ++ show x + sqlType _ = SqlDayTime + +instance PersistField a => PersistField (Maybe a) where + toPersistValue Nothing = PersistNull + toPersistValue (Just a) = toPersistValue a + fromPersistValue PersistNull = Right Nothing + fromPersistValue x = fmap Just $ fromPersistValue x + sqlType _ = sqlType (error "this is the problem" :: a) + isNullable _ = True + +-- | A single database entity. For example, if writing a blog application, a +-- blog entry would be an entry, containing fields such as title and content. +class PersistEntity val where + -- | The monad transformer in which actions for this entity must occur. For + -- example, entities declared to work with a sqlite backend would most + -- likely use a ReaderT monad transformer holding onto a database + -- connection. + -- + -- By using a monad transformer here, users can allow arbitrary effects to + -- exist in the underlying monad. For example, Yesod applications can embed + -- a Handler monad here. The only restriction on that underlying monad is + -- it must be an instance of 'MonadCatchIO'. + type PersistMonad val :: (* -> *) -> * -> * + + -- | The unique identifier associated with this entity. In general, backends also define a type synonym for this, such that \"type MyEntityId = Key MyEntity\". + data Key val + -- | Fields which can be updated using the 'update' and 'updateWhere' + -- functions. + data Update val + -- | Filters which are available for 'select', 'updateWhere' and + -- 'deleteWhere'. Each filter constructor specifies the field being + -- filtered on, the type of comparison applied (equals, not equals, etc) + -- and the argument for the comparison. + data Filter val + -- | How you can sort the results of a 'select'. + data Order val + -- | Unique keys in existence on this entity. + data Unique val + + -- | Prepare database for this entity, if necessary. In SQL, this creates + -- values and indices if they don't exist. The first argument is not used, + -- so you can used 'undefined'. + initialize :: MonadCatchIO m => val -> (PersistMonad val) m () + + -- | Create a new record in the database, returning the newly created + -- identifier. + insert :: MonadCatchIO m => val -> (PersistMonad val) m (Key val) + + -- | Replace the record in the database with the given key. Result is + -- undefined if such a record does not exist. + replace :: MonadCatchIO m => Key val -> val -> (PersistMonad val) m () + + -- | Update individual fields on a specific record. + update :: MonadCatchIO m => Key val -> [Update val] + -> (PersistMonad val) m () + + -- | Update individual fields on any record matching the given criterion. + updateWhere :: MonadCatchIO m => [Filter val] -> [Update val] + -> (PersistMonad val) m () + + -- | Delete a specific record by identifier. Does nothing if record does + -- not exist. + delete :: MonadCatchIO m => Key val -> (PersistMonad val) m () + + -- | Delete a specific record by unique key. Does nothing if no record + -- matches. + deleteBy :: MonadCatchIO m => Unique val -> (PersistMonad val) m () + + -- | Delete all records matching the given criterion. + deleteWhere :: MonadCatchIO m => [Filter val] -> (PersistMonad val) m () + + -- | Get a record by identifier, if available. + get :: MonadCatchIO m => Key val -> (PersistMonad val) m (Maybe val) + + -- | Get a record by unique key, if available. Returns also the identifier. + getBy :: MonadCatchIO m => Unique val + -> (PersistMonad val) m (Maybe (Key val, val)) + + -- | Get all records matching the given criterion in the specified order. + -- Returns also the identifiers. + select :: MonadCatchIO m => [Filter val] -> [Order val] + -> (PersistMonad val) m [(Key val, val)] diff --git a/Database/Persist/GenericSql.hs b/Database/Persist/GenericSql.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/GenericSql.hs @@ -0,0 +1,356 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +-- | This is a helper module for creating SQL backends. Regular users do not +-- need to use this module. +module Database.Persist.GenericSql + ( Int64 + , module Database.Persist.Helper + , persist + , deriveGenericSql + , RowPopper + , GenericSql (..) + ) where + +import Database.Persist (PersistEntity, Key, Order, Filter, Update, + Unique, SqlType (..), PersistValue (..), + PersistField (..)) +import Database.Persist.Helper +import Language.Haskell.TH.Syntax hiding (lift) +import qualified Language.Haskell.TH.Syntax as TH +import Data.List (intercalate) +import Control.Monad (unless, liftM) +import Data.Int (Int64) +import Database.Persist.Quasi +import Control.Arrow (second) + +data GenericSql m = GenericSql + { gsWithStmt :: forall a. + String -> [PersistValue] -> (RowPopper m -> m a) -> m a + , gsExecute :: String -> [PersistValue] -> m () + , gsInsert :: String -> [String] -> [PersistValue] -> m Int64 + , gsEntityDefExists :: String -> m Bool + , gsKeyType :: String + } + +type RowPopper m = m (Maybe [PersistValue]) + +deriveGenericSql :: Type -> Exp -> EntityDef -> Q [Dec] +deriveGenericSql monad gs t = do + let name = entityName t + let dt = dataTypeDec t + + fsv <- mkFromPersistValues t + let sq = + InstanceD [] (ConT ''FromPersistValues `AppT` ConT (mkName name)) + [ FunD (mkName "fromPersistValues") fsv + ] + + let keysyn = TySynD (mkName $ name ++ "Id") [] $ + ConT ''Key `AppT` ConT (mkName name) + + t' <- TH.lift t + let mkFun s e = FunD (mkName s) [Clause [] (NormalB $ e `AppE` t') []] + + let gs' = fmap (`AppE` gs) + init' <- gs' [|initialize|] + insert' <- gs' [|insert|] + replace' <- gs' [|replace|] + get' <- gs' [|get|] + getBy' <- gs' [|getBy|] + select' <- gs' [|select|] + deleteWhere' <- gs' [|deleteWhere|] + delete' <- gs' [|delete|] + deleteBy' <- gs' [|deleteBy|] + update' <- gs' [|update|] + updateWhere' <- gs' [|updateWhere|] + + let inst = + InstanceD + [] + (ConT ''PersistEntity `AppT` ConT (mkName name)) + [ persistMonadTypeDec monad t + , keyTypeDec (name ++ "Id") "Int64" t + , filterTypeDec t + , updateTypeDec t + , orderTypeDec t + , uniqueTypeDec t + , mkFun "initialize" $ init' + , mkFun "insert" $ insert' + , mkFun "replace" $ replace' + , mkFun "get" $ get' + , mkFun "getBy" $ getBy' + , mkFun "select" $ select' + , mkFun "deleteWhere" $ deleteWhere' + , mkFun "delete" $ delete' + , mkFun "deleteBy" $ deleteBy' + , mkFun "update" $ update' + , mkFun "updateWhere" $ updateWhere' + ] + + tops <- mkToPersistFields (ConT $ mkName name) + [(name, length $ tableColumns t)] + topsUn <- mkToPersistFields (ConT ''Unique `AppT` ConT (mkName name)) + $ map (\(x, y) -> (x, length y)) + $ entityUniques t + + return + [ dt, sq, inst, keysyn, tops, topsUn + , mkToFieldName (ConT ''Update `AppT` ConT (mkName name)) + $ map (\(s, _, _) -> (name ++ upperFirst s, s)) + $ entityUpdates t + , mkPersistField (ConT ''Update `AppT` ConT (mkName name)) + $ map (\(s, _, _) -> name ++ upperFirst s) $ entityUpdates t + , mkToFieldNames (ConT ''Unique `AppT` ConT (mkName name)) + $ entityUniques t + , mkPersistField (ConT ''Filter `AppT` ConT (mkName name)) + $ map (\(x, _, _, y) -> name ++ upperFirst x ++ show y) + $ entityFilters t + , mkToFieldName (ConT ''Filter `AppT` ConT (mkName name)) + $ map (\(x, _, _, y) -> (name ++ upperFirst x ++ show y, x)) + $ entityFilters t + , mkToFilter (ConT ''Filter `AppT` ConT (mkName name)) + $ map (\(x, _, z, y) -> + (name ++ upperFirst x ++ show y, y, z)) + $ entityFilters t + , mkToFieldName (ConT ''Order `AppT` ConT (mkName name)) + $ map (\(x, y) -> (name ++ upperFirst x ++ y, x)) + $ entityOrders t + , mkToOrder (ConT ''Order `AppT` ConT (mkName name)) + $ map (\(x, y) -> (name ++ upperFirst x ++ y, y)) + $ entityOrders t + , mkHalfDefined (ConT $ mkName name) name $ length $ tableColumns t + ] + +initialize :: (ToPersistFields v, Monad m, HalfDefined v) + => GenericSql m -> EntityDef -> v -> m () +initialize gs t v = do + doesExist <- gsEntityDefExists gs $ tableName t + unless doesExist $ do + let cols = zip (tableColumns t) $ toPersistFields + $ halfDefined `asTypeOf` v + let sql = "CREATE TABLE " ++ tableName t ++ + "(id " ++ gsKeyType gs ++ + concatMap go' cols ++ ")" + gsExecute gs sql [] + mapM_ go $ tableUniques' t + where + go' ((colName, _, as), p) = concat + [ "," + , colName + , " " + , showSqlType $ sqlType p + , if "null" `elem` as then " NULL" else " NOT NULL" + ] + go (index, fields) = do + let sql = "CREATE UNIQUE INDEX " ++ index ++ " ON " ++ + tableName t ++ "(" ++ intercalate "," fields ++ ")" + gsExecute gs sql [] + showSqlType SqlString = "VARCHAR" + showSqlType SqlInteger = "INTEGER" + showSqlType SqlReal = "REAL" + showSqlType SqlDay = "DATE" + showSqlType SqlTime = "TIME" + showSqlType SqlDayTime = "TIMESTAMP" + showSqlType SqlBlob = "BLOB" + showSqlType SqlBool = "BOOLEAN" + +mkFromPersistValues :: EntityDef -> Q [Clause] +mkFromPersistValues t = do + nothing <- [|Left "Invalid fromPersistValues input"|] + let cons = ConE $ mkName $ entityName t + xs <- mapM (const $ newName "x") $ entityColumns t + fs <- [|fromPersistValue|] + let xs' = map (AppE fs . VarE) xs + let pat = ListP $ map VarP xs + ap' <- [|apE|] + just <- [|Right|] + let cons' = just `AppE` cons + return + [ Clause [pat] (NormalB $ foldl (go ap') cons' xs') [] + , Clause [WildP] (NormalB nothing) [] + ] + where + go ap' x y = InfixE (Just x) ap' (Just y) + +insert :: (Monad m, ToPersistFields val, Num (Key val)) + => GenericSql m -> EntityDef -> val -> m (Key val) +insert gs t = liftM fromIntegral + . gsInsert gs (tableName t) (map fst3 $ tableColumns t) + . toPersistValues + where + fst3 (x, _, _) = x + +replace :: (Integral (Key v), ToPersistFields v, Monad m) + => GenericSql m -> EntityDef -> Key v -> v -> m () +replace gs t k val = do + let sql = "UPDATE " ++ tableName t ++ " SET " ++ + intercalate "," (map (go . fst3) $ tableColumns t) ++ + " WHERE id=?" + gsExecute gs sql $ + map toPersistValue (toPersistFields val) + ++ [PersistInt64 (fromIntegral k)] + where + go = (++ "=?") + fst3 (x, _, _) = x + +get :: (Integral (Key v), FromPersistValues v, Monad m) + => GenericSql m -> EntityDef -> Key v -> m (Maybe v) +get gs t k = do + let sql = "SELECT * FROM " ++ tableName t ++ " WHERE id=?" + gsWithStmt gs sql [PersistInt64 $ fromIntegral k] $ \pop -> do + res <- pop + case res of + Nothing -> return Nothing + Just (_:vals) -> + case fromPersistValues vals of + Left e -> error $ "get " ++ show k ++ ": " ++ e + Right v -> return $ Just v + Just [] -> error "Database.Persist.GenericSql: Empty list in get" + +select :: ( FromPersistValues val, Num key + , PersistField (Filter val), ToFieldName (Filter val) + , ToFilter (Filter val), ToFieldName (Order val) + , ToOrder (Order val), Monad m + ) + => GenericSql m + -> EntityDef + -> [Filter val] + -> [Order val] + -> m [(key, val)] +select gs t filts ords = do + let wher = if null filts + then "" + else " WHERE " ++ + intercalate " AND " (map filterClause filts) + ord = if null ords + then "" + else " ORDER BY " ++ + intercalate "," (map orderClause ords) + let sql = "SELECT * FROM " ++ tableName t ++ wher ++ ord + gsWithStmt gs sql (map toPersistValue filts) $ flip go id + where + orderClause o = toFieldName' o ++ case toOrder o of + Asc -> "" + Desc -> " DESC" + fromPersistValues' (PersistInt64 x:xs) = do + case fromPersistValues xs of + Left e -> Left e + Right xs' -> Right (fromIntegral x, xs') + fromPersistValues' _ = Left "error in fromPersistValues'" + go pop front = do + res <- pop + case res of + Nothing -> return $ front [] + Just vals -> do + case fromPersistValues' vals of + Left _ -> go pop front -- FIXME error? + Right row -> go pop $ front . (:) row + +filterClause :: (ToFilter f, ToFieldName f) => f -> String +filterClause f = if isNull f then nullClause else mainClause + where + mainClause = toFieldName' f ++ showSqlFilter (toFilter f) ++ "?" + nullClause = + case toFilter f of + Eq -> '(' : mainClause ++ " OR " ++ toFieldName' f ++ " IS NULL)" + Ne -> '(' : mainClause ++ " OR " ++ toFieldName' f ++ " IS NOT NULL)" + _ -> mainClause + showSqlFilter Eq = "=" + showSqlFilter Ne = "<>" + showSqlFilter Gt = ">" + showSqlFilter Lt = "<" + showSqlFilter Ge = ">=" + showSqlFilter Le = "<=" + +delete :: (Integral (Key v), Monad m) + => GenericSql m -> EntityDef -> Key v -> m () +delete gs t k = + gsExecute gs sql [PersistInt64 $ fromIntegral k] + where + sql = "DELETE FROM " ++ tableName t ++ " WHERE id=?" + +deleteWhere :: (PersistField (Filter v), ToFilter (Filter v), + ToFieldName (Filter v), Monad m) + => GenericSql m -> EntityDef -> [Filter v] -> m () +deleteWhere gs t filts = do + let wher = if null filts + then "" + else " WHERE " ++ + intercalate " AND " (map filterClause filts) + sql = "DELETE FROM " ++ tableName t ++ wher + gsExecute gs sql $ map toPersistValue filts + +deleteBy :: (ToPersistFields (Unique v), ToFieldNames (Unique v), Monad m) + => GenericSql m -> EntityDef -> Unique v -> m () +deleteBy gs t uniq = do + let sql = "DELETE FROM " ++ tableName t ++ " WHERE " ++ + intercalate " AND " (map (++ "=?") $ toFieldNames' uniq) + gsExecute gs sql $ map toPersistValue $ toPersistFields uniq + +update :: ( Integral (Key v), PersistField (Update v), ToFieldName (Update v) + , Monad m) + => GenericSql m -> EntityDef -> Key v -> [Update v] -> m () +update _ _ _ [] = return () +update gs t k upds = do + let sql = "UPDATE " ++ tableName t ++ " SET " ++ + intercalate "," (map (++ "=?") $ map toFieldName' upds) ++ + " WHERE id=?" + gsExecute gs sql $ + map toPersistValue upds ++ [PersistInt64 $ fromIntegral k] + +updateWhere :: (PersistField (Filter v), PersistField (Update v), + ToFieldName (Update v), ToFilter (Filter v), + ToFieldName (Filter v), Monad m) + => GenericSql m + -> EntityDef -> [Filter v] -> [Update v] -> m () +updateWhere _ _ _ [] = return () +updateWhere gs t filts upds = do + let wher = if null filts + then "" + else " WHERE " ++ + intercalate " AND " (map filterClause filts) + let sql = "UPDATE " ++ tableName t ++ " SET " ++ + intercalate "," (map (++ "=?") $ map toFieldName' upds) ++ wher + let dat = map toPersistValue upds ++ map toPersistValue filts + gsWithStmt gs sql dat $ const $ return () + +getBy :: (Num (Key v), FromPersistValues v, Monad m, + ToPersistFields (Unique v), ToFieldNames (Unique v)) + => GenericSql m + -> EntityDef -> Unique v -> m (Maybe (Key v, v)) +getBy gs t uniq = do + let sql = "SELECT * FROM " ++ tableName t ++ " WHERE " ++ sqlClause + gsWithStmt gs sql (toPersistValues uniq) $ \pop -> do + row <- pop + case row of + Nothing -> return Nothing + Just (PersistInt64 k:vals) -> + case fromPersistValues vals of + Left _ -> return Nothing + Right x -> return $ Just (fromIntegral k, x) + Just _ -> error "Database.Persist.GenericSql: Bad list in getBy" + where + sqlClause = intercalate " AND " $ map (++ "=?") $ toFieldNames' uniq + +tableName :: EntityDef -> String +tableName t = "tbl" ++ entityName t + +toField :: String -> String +toField = (++) "fld" + +tableColumns :: EntityDef -> [(String, String, [String])] +tableColumns = map (\(x, y, z) -> (toField x, y, z)) . entityColumns + +tableUniques' :: EntityDef -> [(String, [String])] +tableUniques' = map (second $ map toField) . entityUniques + +toFieldName' :: ToFieldName x => x -> String +toFieldName' = toField . toFieldName + +toFieldNames' :: ToFieldNames x => x -> [String] +toFieldNames' = map toField . toFieldNames diff --git a/Database/Persist/Helper.hs b/Database/Persist/Helper.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Helper.hs @@ -0,0 +1,326 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ExistentialQuantification #-} +-- | This module provides utilities for creating backends. Regular users do not +-- need to use this module. +module Database.Persist.Helper + ( recName + , upperFirst + -- * High level design + , EntityDef (..) + , entityOrders + , entityFilters + , entityUpdates + -- * TH datatype helpers + , dataTypeDec + , persistMonadTypeDec + , keyTypeDec + , filterTypeDec + , updateTypeDec + , orderTypeDec + , uniqueTypeDec + -- * TH typeclass helpers + , mkToPersistFields + , mkToFieldNames + , mkToFieldName + , mkPersistField + , mkToFilter + , mkToOrder + , mkHalfDefined + -- * Type classes + , SomePersistField (..) + , ToPersistFields (..) + , FromPersistValues (..) + , toPersistValues + , ToFieldNames (..) + , ToOrder (..) + , PersistOrder (..) + , ToFieldName (..) + , PersistFilter (..) + , ToFilter (..) + , HalfDefined (..) + -- * Utils + , apE + , addIsNullable + ) where + +import Database.Persist +import Language.Haskell.TH.Syntax +import Data.Char (toLower, toUpper) +import Data.Maybe (fromJust, mapMaybe) +import Web.Routes.Quasi (SinglePiece) + +data EntityDef = EntityDef + { entityName :: String + , entityColumns :: [(String, String, [String])] -- ^ name, type, attribs + , entityUniques :: [(String, [String])] -- ^ name, columns + , entityDerives :: [String] + } + deriving Show + +instance Lift EntityDef where + lift (EntityDef a b c d) = do + e <- [|EntityDef|] + a' <- lift a + b' <- lift b + c' <- lift c + d' <- lift d + return $ e `AppE` a' `AppE` b' `AppE` c' `AppE` d' + +recName :: String -> String -> String +recName dt f = lowerFirst dt ++ upperFirst f + +lowerFirst :: String -> String +lowerFirst (x:xs) = toLower x : xs +lowerFirst [] = [] + +upperFirst :: String -> String +upperFirst (x:xs) = toUpper x : xs +upperFirst [] = [] + +dataTypeDec :: EntityDef -> Dec +dataTypeDec t = + let name = mkName $ entityName t + cols = map (mkCol $ entityName t) $ entityColumns t + in DataD [] name [] [RecC name cols] $ map mkName $ entityDerives t + where + mkCol x (n, ty, as) = + (mkName $ recName x n, NotStrict, pairToType (ty, "null" `elem` as)) + +persistMonadTypeDec :: Type -> EntityDef -> Dec +persistMonadTypeDec monad t = + TySynInstD ''PersistMonad [ConT $ mkName $ entityName t] monad + +keyTypeDec :: String -> String -> EntityDef -> Dec +keyTypeDec constr typ t = + NewtypeInstD [] ''Key [ConT $ mkName $ entityName t] + (NormalC (mkName constr) [(NotStrict, ConT $ mkName typ)]) + [''Show, ''Read, ''Num, ''Integral, ''Enum, ''Eq, ''Ord, + ''Real, ''PersistField, ''SinglePiece] + +filterTypeDec :: EntityDef -> Dec +filterTypeDec t = + DataInstD [] ''Filter [ConT $ mkName $ entityName t] + (map (mkFilter $ entityName t) filts) + (if null filts then [] else [''Show, ''Read, ''Eq]) + where + filts = entityFilters t + +entityFilters :: EntityDef -> [(String, String, Bool, PersistFilter)] +entityFilters = mapMaybe go' . concatMap go . entityColumns + where + go (x, y, as) = map (\a -> (x, y, "null" `elem` as, a)) as + go' (x, y, z, a) = + case readMay a of + Nothing -> Nothing + Just a' -> Just (x, y, z, a') + readMay s = + case reads s of + (x, _):_ -> Just x + [] -> Nothing + +mkFilter :: String -> (String, String, Bool, PersistFilter) -> Con +mkFilter x (s, ty, isNull', filt) = + NormalC (mkName $ x ++ upperFirst s ++ show filt) + [(NotStrict, pairToType (ty, isNull'))] + +updateTypeDec :: EntityDef -> Dec +updateTypeDec t = + DataInstD [] ''Update [ConT $ mkName $ entityName t] + (map (mkUpdate $ entityName t) tu) + (if null tu then [] else [''Show, ''Read, ''Eq]) + where + tu = entityUpdates t + +entityUpdates :: EntityDef -> [(String, String, Bool)] +entityUpdates = mapMaybe go . entityColumns + where + go (name, typ, attribs) + | "update" `elem` attribs = + Just (name, typ, "null" `elem` attribs) + | otherwise = Nothing + +mkUpdate :: String -> (String, String, Bool) -> Con +mkUpdate x (s, ty, isBool) = + NormalC (mkName $ x ++ upperFirst s) + [(NotStrict, pairToType (ty, isBool))] + +orderTypeDec :: EntityDef -> Dec +orderTypeDec t = + DataInstD [] ''Order [ConT $ mkName $ entityName t] + (map (mkOrder $ entityName t) ords) + (if null ords then [] else [''Show, ''Read, ''Eq]) + where + ords = entityOrders t + +entityOrders :: EntityDef -> [(String, String)] +entityOrders = concatMap go . entityColumns + where + go (x, _, ys) = mapMaybe (go' x) ys + go' x "Asc" = Just (x, "Asc") + go' x "Desc" = Just (x, "Desc") + go' _ _ = Nothing + +mkOrder :: String -> (String, String) -> Con +mkOrder x (s, ad) = NormalC (mkName $ x ++ upperFirst s ++ ad) [] + +uniqueTypeDec :: EntityDef -> Dec +uniqueTypeDec t = + DataInstD [] ''Unique [ConT $ mkName $ entityName t] + (map (mkUnique t) $ entityUniques t) + (if null (entityUniques t) then [] else [''Show, ''Read, ''Eq]) + +mkUnique :: EntityDef -> (String, [String]) -> Con +mkUnique t (constr, fields) = + NormalC (mkName constr) types + where + types = map (go . fromJust . flip lookup3 (entityColumns t)) fields + go (_, True) = error "Error: cannot have nullables in unique" + go x = (NotStrict, pairToType x) + lookup3 _ [] = Nothing + lookup3 x ((x', y, z):rest) + | x == x' = Just (y, "null" `elem` z) + | otherwise = lookup3 x rest + +pairToType :: (String, Bool) -> Type +pairToType (s, False) = ConT $ mkName s +pairToType (s, True) = ConT (mkName "Maybe") `AppT` ConT (mkName s) + +data SomePersistField = forall a. PersistField a => SomePersistField a +instance PersistField SomePersistField where + toPersistValue (SomePersistField a) = toPersistValue a + fromPersistValue x = fmap SomePersistField (fromPersistValue x :: Either String String) + sqlType (SomePersistField a) = sqlType a + +class ToPersistFields a where + toPersistFields :: a -> [SomePersistField] + +degen :: [Clause] -> [Clause] +degen [] = + let err = VarE (mkName "error") `AppE` LitE (StringL + "Degenerate case, should never happen") + in [Clause [WildP] (NormalB err) []] +degen x = x + +mkToPersistFields :: Type + -> [(String, Int)] + -> Q Dec +mkToPersistFields typ pairs = do + clauses <- mapM go pairs + return $ InstanceD [] (ConT ''ToPersistFields `AppT` typ) + [FunD (mkName "toPersistFields") $ degen clauses] + where + go (constr, fields) = do + xs <- sequence $ replicate fields $ newName "x" + let pat = ConP (mkName constr) $ map VarP xs + sp <- [|SomePersistField|] + let bod = ListE $ map (AppE sp . VarE) xs + return $ Clause [pat] (NormalB bod) [] + +class FromPersistValues a where + fromPersistValues :: [PersistValue] -> Either String a + +toPersistValues :: ToPersistFields a => a -> [PersistValue] +toPersistValues = map toPersistValue . toPersistFields + +class ToFieldNames a where + toFieldNames :: a -> [String] + +mkToFieldNames :: Type -> [(String, [String])] -> Dec +mkToFieldNames typ pairs = + InstanceD [] (ConT ''ToFieldNames `AppT` typ) + [FunD (mkName "toFieldNames") $ degen $ map go pairs] + where + go (constr, names) = + Clause [RecP (mkName constr) []] + (NormalB $ ListE $ map (LitE . StringL) names) + [] + +class ToFieldName a where + toFieldName :: a -> String + +mkToFieldName :: Type -> [(String, String)] -> Dec +mkToFieldName typ pairs = + InstanceD [] (ConT ''ToFieldName `AppT` typ) + [FunD (mkName "toFieldName") $ degen $ map go pairs] + where + go (constr, name) = + Clause [RecP (mkName constr) []] (NormalB $ LitE $ StringL name) [] + +data PersistOrder = Asc | Desc +class ToOrder a where + toOrder :: a -> PersistOrder + +mkToOrder :: Type -> [(String, String)] -> Dec +mkToOrder typ pairs = + InstanceD [] (ConT ''ToOrder `AppT` typ) + [FunD (mkName "toOrder") $ degen $ map go pairs] + where + go (constr, val) = + Clause [RecP (mkName constr) []] (NormalB $ ConE $ mkName val) [] + +data PersistFilter = Eq | Ne | Gt | Lt | Ge | Le + deriving (Read, Show) +class ToFilter a where + toFilter :: a -> PersistFilter + isNull :: a -> Bool + +mkToFilter :: Type -> [(String, PersistFilter, Bool)] -> Dec +mkToFilter typ pairs = + InstanceD [] (ConT ''ToFilter `AppT` typ) + [ FunD (mkName "toFilter") $ degen $ map go pairs + , FunD (mkName "isNull") $ degen $ concatMap go' pairs + ] + where + go (constr, pf, _) = + Clause [RecP (mkName constr) []] (NormalB $ ConE $ mkName $ show pf) [] + go' (constr, _, False) = + [Clause [RecP (mkName constr) []] + (NormalB $ ConE $ mkName "False") []] + go' (constr, _, True) = + [ Clause [ConP (mkName constr) [ConP (mkName "Nothing") []]] + (NormalB $ ConE $ mkName "True") [] + , Clause [ConP (mkName constr) [WildP]] + (NormalB $ ConE $ mkName "False") [] + ] + +mkPersistField :: Type -> [String] -> Dec +mkPersistField typ constrs = + InstanceD [] (ConT ''PersistField `AppT` typ) + $ fpv : map go + [ "toPersistValue" + , "sqlType" + , "isNullable" + ] + where + go func = FunD (mkName func) $ degen $ map (go' func) constrs + go' func constr = + let x = mkName "x" + in Clause [ConP (mkName constr) [VarP x]] + (NormalB $ VarE (mkName func) `AppE` VarE x) + [] + fpv = FunD (mkName "fromPersistValue") + [Clause [WildP] (NormalB $ VarE (mkName "error") + `AppE` LitE (StringL "fromPersistValue")) []] + +class HalfDefined a where + halfDefined :: a + +mkHalfDefined :: Type -> String -> Int -> Dec +mkHalfDefined typ constr count = + InstanceD [] (ConT ''HalfDefined `AppT` typ) + [FunD (mkName "halfDefined") + [Clause [] (NormalB + $ foldl AppE (ConE $ mkName constr) + (replicate count $ VarE $ mkName "undefined")) []]] + +apE :: Either x (y -> z) -> Either x y -> Either x z +apE (Left x) _ = Left x +apE _ (Left x) = Left x +apE (Right f) (Right y) = Right $ f y + +addIsNullable :: EntityDef -> (String, (String, String)) + -> (String, (String, Bool)) +addIsNullable ed (col, (name, typ)) = + case filter (\(x, _, _) -> x == col) $ entityColumns ed of + [] -> error $ "Missing columns: " ++ col ++ ", " ++ show ed + (_, _, attribs):_ -> (name, (typ, "null" `elem` attribs)) diff --git a/Database/Persist/Quasi.hs b/Database/Persist/Quasi.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Quasi.hs @@ -0,0 +1,56 @@ +module Database.Persist.Quasi + ( persist + ) where + +import Language.Haskell.TH.Quote +import Language.Haskell.TH.Syntax +import Database.Persist.Helper +import Data.Char +import Data.Maybe (mapMaybe) + +-- | Converts a quasi-quoted syntax into a list of entity definitions, to be +-- used as input to the backend-specific template haskell generation code. +persist :: QuasiQuoter +persist = QuasiQuoter + { quoteExp = lift . parse + , quotePat = error "Cannot quasi-quote a Persist pattern." + } + +parse :: String -> [EntityDef] +parse = map parse' . nest . map words' . filter (not . null) . lines + +words' :: String -> (Bool, [String]) +words' (' ':x) = (True, words x) +words' x = (False, words x) + +nest :: [(Bool, [String])] -> [(String, [[String]])] +nest ((False, [name]):rest) = + let (x, y) = break (not . fst) rest + in (name, map snd x) : nest y +nest ((False, _):_) = error "First line in block must have exactly one word" +nest ((True, _):_) = error "Blocks must begin with non-indented lines" +nest [] = [] + +parse' :: (String, [[String]]) -> EntityDef +parse' (name, attribs) = EntityDef name cols uniqs derives + where + cols = concatMap takeCols attribs + uniqs = concatMap takeUniqs attribs + derives = case mapMaybe takeDerives attribs of + [] -> ["Show", "Read", "Eq"] + x -> concat x + +takeCols :: [String] -> [(String, String, [String])] +takeCols ("deriving":_) = [] +takeCols (n@(f:_):ty:rest) + | isLower f = [(n, ty, rest)] +takeCols _ = [] + +takeUniqs :: [String] -> [(String, [String])] +takeUniqs (n@(f:_):rest) + | isUpper f = [(n, rest)] +takeUniqs _ = [] + +takeDerives :: [String] -> Maybe [String] +takeDerives ("deriving":rest) = Just rest +takeDerives _ = Nothing diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2010, Michael Snoyman. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/persistent.cabal b/persistent.cabal new file mode 100644 --- /dev/null +++ b/persistent.cabal @@ -0,0 +1,33 @@ +name: persistent +version: 0.0.0 +license: BSD3 +license-file: LICENSE +author: Michael Snoyman +maintainer: Michael Snoyman +synopsis: Type-safe, non-relational, multi-backend persistence. +description: This library provides just the general interface and helper functions. You must use a specific backend in order to make this useful. +category: Database +stability: Stable +cabal-version: >= 1.6 +build-type: Simple +homepage: http://docs.yesodweb.com/persistent/ + +library + build-depends: base >= 4 && < 5, + template-haskell >= 2.4 && < 2.5, + bytestring >= 0.9.1 && < 0.10, + MonadCatchIO-transformers >= 0.2.2 && < 0.3, + time >= 1.1.4 && < 1.2, + utf8-string >= 0.3.4 && < 0.4, + text >= 0.7.1 && < 0.8, + hamlet >= 0.3.1 && < 0.4, + web-routes-quasi >= 0.4.0 && < 0.5 + exposed-modules: Database.Persist + Database.Persist.Helper + Database.Persist.Quasi + Database.Persist.GenericSql + ghc-options: -Wall + +source-repository head + type: git + location: git://github.com/snoyberg/persistent.git