{-# LANGUAGE ExistentialQuantification, FlexibleInstances #-} {-# OPTIONS_GHC -fallow-undecidable-instances -fallow-incoherent-instances #-} module RESTng.System.ORM where import Data.Maybe import Data.List (intercalate) import Database.HDBC import Database.HDBC.PostgreSQL (Connection, connectPostgreSQL) import Control.Monad.Error import Data.Typeable (TypeRep) import Data.Generics import RESTng.Utils (safeHead, low) import RESTng.System.Resource import RESTng.System.RelationalResource import RESTng.System.ORMTypesConv ------------------------------------------- ------ Table type ----------------------- ------------------------------------------- type AttrDesc = (String, -- name SqlColumnDesc, -- type Maybe String) -- default value type TableDesc = (String, -- name [AttrDesc]) ------------------------------------------- ------ Error type and Error Monads -------- ------------------------------------------- data OrmError = DbCmdError String -- the hdbc command failed. Track sql command and error message | NoSqlColumnDescr [TypeRep] -- no description associated for these types. -- | NeedDefaultValuesFor [String] -- list of not null attributes | OtherError String deriving Show instance Error OrmError where noMsg = OtherError "ORM error" strMsg s = OtherError s type OrmMonad = Either OrmError type OrmMonadIO = ErrorT OrmError IO runOrmMonadIO :: OrmMonadIO a -> IO (Either OrmError a) runOrmMonadIO = runErrorT ormMonad :: OrmMonad a -> OrmMonadIO a ormMonad o = ErrorT $ return o liftSqlError :: IO a -> OrmMonadIO a liftSqlError action = ErrorT $ catchSql (fmap Right action) (return . Left . DbCmdError . show) --------------------------------------------------------- ------ Class of resources whose tables can be created -- --------------------------------------------------------- class RelationalResource a => CanCreateSchemaForResource a where userFieldsReps :: Proxy a -> [TypeRep] userFieldsDefaultValues :: Proxy a -> [Maybe String] -- default value sql expression userFieldsColDesc :: CanCreateSchemaForResource a => Proxy a -> TypesAssoc -> Either OrmError [SqlColumnDesc] userFieldsColDesc pr assoc = case partitionEithers translationList of ([], coldescs) -> Right coldescs (typeReps, _) -> Left $ NoSqlColumnDescr typeReps where translationList :: [Either TypeRep SqlColumnDesc] translationList = map worker $ zip usrfields (map (`typeRepToSqlColumnDesc` assoc) usrfields) usrfields = userFieldsReps pr worker (typeRep, Nothing) = Left typeRep worker (_, Just coldesc) = Right coldesc partitionEithers l = (lefts l, rights l) lefts = catMaybes . map (either Just (\_->Nothing)) rights = catMaybes . map (either (\_->Nothing) Just) usrFieldsSqlAttrs :: CanCreateSchemaForResource a => Proxy a -> TypesAssoc -> OrmMonad [AttrDesc] usrFieldsSqlAttrs pr assoc = do uColDescs <- userFieldsColDesc pr assoc return $ zip3 (map low $ userFields pr) uColDescs (userFieldsDefaultValues pr) systemFieldsSqlAttrs :: CanCreateSchemaForResource a => Proxy a -> [AttrDesc] systemFieldsSqlAttrs pr = ("id",(SqlBigIntT, False), Nothing) : maybeOwnerAttr where maybeOwnerAttr = if ownable pr then [ (ownerIdName pr, (SqlBigIntT, False), Nothing) ] else [] -------------------------------------------------------------------------------------- -- Highest level functions for creating resources for an heterogeneous lists of res -- -------------------------------------------------------------------------------------- data CanCreateSchemaProxyBox = forall a. (CanCreateSchemaForResource a) => CrBox (Proxy a) ensureResourceTables :: [CanCreateSchemaProxyBox] -> TypesAssoc -> String -> IO () ensureResourceTables boxList assoc connStr = handleSqlError $ do conn <- connectPostgreSQL connStr ts <- fmap (map low) $ getTables conn sequence_ $ map (\box -> ensureBoxedResourceTable box assoc ts conn) boxList disconnect conn ensureBoxedResourceTable :: CanCreateSchemaProxyBox -> TypesAssoc -> [String] -> Connection -> IO Bool ensureBoxedResourceTable (CrBox pr) = ensureResourceTable pr ensureResourceTable :: CanCreateSchemaForResource a => Proxy a -> TypesAssoc -> [String] -> Connection -> IO Bool ensureResourceTable pr assoc tablesInDB conn = do let tname = low (tableName pr) putStrLn ("Ensuring table: " ++ tname) eitherResult <- runOrmMonadIO $ ensureResourceTable' pr assoc tablesInDB conn case eitherResult of Left e -> do rollback conn putStrLn (tname ++ " FAILURE: " ++ show e) >> putStrLn "" >> putStrLn "" return True Right _ -> do commit conn putStrLn (tname ++ " OK") >> putStrLn "" >> putStrLn "" return False ensureResourceTable' :: CanCreateSchemaForResource a => Proxy a -> TypesAssoc -> [String] -> Connection -> OrmMonadIO () ensureResourceTable' pr assoc tablesInDB conn = do ufieldsAttrs <- ormMonad $ usrFieldsSqlAttrs pr assoc let tname = low (tableName pr) maybeAttrs <- if tname `elem` tablesInDB then fmap Just (describeTableInDB tname conn) else return Nothing ensureTable (tname, systemFieldsSqlAttrs pr ++ ufieldsAttrs) maybeAttrs conn describeTableInDB :: String -> Connection -> OrmMonadIO [AttrDesc] describeTableInDB t conn = do attrDescs <- liftSqlError (describeTable conn t) return $ map makeAttr attrDescs where makeAttr :: (String, SqlColDesc) -> AttrDesc makeAttr (name, colDesc) = (low name, hdbcToSqlColumnDesc colDesc, Nothing) ensureTable :: TableDesc -> Maybe [AttrDesc] -> Connection -> OrmMonadIO () ensureTable t Nothing conn = createTable t conn ensureTable (t, requiredAttrs) (Just attrsInDB) conn = sequence_ $ map ensureAttr' requiredAttrs where ensureAttr' reqAttr = ensureAttr t reqAttr attrsInDB conn ensureAttr :: String -> AttrDesc -> [AttrDesc] -> Connection -> OrmMonadIO () ensureAttr t (colName, colDesc, defValue) attrsInDB conn = case maybeSameInDB of Nothing -> addColumn t (colName, colDesc, defValue) conn (Just (_, cDesc, defVal)) -> ensureAttrTypeAndDef t colName (colDesc, defValue) (cDesc, defVal) conn where maybeSameInDB = safeHead $ filter (\(n,_,_)-> n==colName) attrsInDB ensureAttrTypeAndDef :: String -> String -> (SqlColumnDesc, Maybe String) -> (SqlColumnDesc, Maybe String) -> Connection -> OrmMonadIO () ensureAttrTypeAndDef t colName ((reqColType,reqColNullable), reqDefValue) ((colTypeInDB,colNullableInDB), defValueInDB) conn = if reqColType /= colTypeInDB then do -- the attribute in DB has a different type, then rename it and create a new one renameColumnInteractive t colName conn addColumn t (colName, (reqColType,reqColNullable), reqDefValue) conn else do if reqColNullable /= colNullableInDB then setNullable t colName reqColNullable conn else return () ensureAttrDef t colName reqDefValue defValueInDB conn ensureAttrDef :: String -> String -> Maybe String -> Maybe String -> Connection -> OrmMonadIO () ensureAttrDef t colname reqDefValue _ conn = setDefault t colname reqDefValue conn -- FIXME: get default value in DB and compare with required one to do or avoid the setting/dropping -- getting the default in DB must be done in other function. Since it is not being done yet -- we ignore the parameter here (we macht it with _ ) ----------------------------------------------------------- -- Not so high level functions acting on the db ----------- ----------------------------------------------------------- createTable :: TableDesc -> Connection -> OrmMonadIO () createTable (t, attrs) conn = do liftSqlError $ do putStrLn " A table will be created" putStrLn (" Query: \"" ++ createSql ++ "\"") putStrLn "" run conn createSql [] liftSqlError $ do putStrLn " The primary key will be set" putStrLn (" Query: \"" ++ addPKSql ++ "\"") putStrLn "" run conn addPKSql [] return () where createSql = createTableSql t attrs addPKSql = addPrimaryKeySql t addColumn :: String -> AttrDesc -> Connection -> OrmMonadIO () addColumn t (colName, coldesc, columnDefVal) conn = do liftSqlError $ do putStrLn " A column will be added" putStrLn (" Query: \"" ++ addColSql ++ "\"") putStrLn "" run conn addColSql [] return () where addColSql = addColumnSql t colName coldesc columnDefVal --FIXME: allow setting default just for a while if necessary for this step. --preguntar cuantas filas hay. SELECT COUNT (*) FROM table renameColumnInteractive :: String -> String -> Connection -> OrmMonadIO () renameColumnInteractive t colName conn = do ds <- liftSqlError $ describeTable conn t renameColumnInteractive' t colName (colName ++ "_old") (map (low . fst) ds) conn renameColumnInteractive' :: String -> String -> String -> [String] -> Connection -> OrmMonadIO () renameColumnInteractive' t colName newName existingColNames conn = if newName `elem` existingColNames then do nameFromUsr <- liftIO (showErrorMsg >> askNewName) if null nameFromUsr then throwError (OtherError $ "Field already in use: " ++ newName) else renameColumnInteractive' t colName nameFromUsr existingColNames conn else renameColumn t colName newName conn where showErrorMsg :: IO () showErrorMsg = do putStrLn ("Need to rename column " ++ colName ++ " but cannot since the new name is already in use (" ++ newName ++ ")") askNewName :: IO String askNewName = do putStrLn "Please enter a new name or an empty string to abort." >> putStr "> " getLine renameColumn :: String -> String -> String -> Connection -> OrmMonadIO () renameColumn t colName newName conn = do liftSqlError $ do putStrLn " A column will be renamed" putStrLn (" Query: \"" ++ renColSql ++ "\"") run conn renColSql [] liftIO $ putStrLn "" where renColSql = renameColumnSql t colName newName setDefault :: String -> String -> Maybe String -> Connection -> OrmMonadIO () setDefault _ "id" _ _ = return () setDefault t colName columnDefVal conn = do liftSqlError $ do putStrLn " A column will be modified for setting or dropping the default value" putStrLn (" Query: \"" ++ setDefSql ++ "\"") putStrLn "" run conn setDefSql [] return () where setDefSql = setDefaultSql t colName columnDefVal setNullable :: String -> String -> Bool -> Connection -> OrmMonadIO () setNullable t colName colNullable conn = do liftSqlError $ do putStrLn " A column will be modified for setting or dropping NOT NULL" putStrLn (" Query: \"" ++ setNullSql ++ "\"") putStrLn "" run conn setNullSql [] return () where setNullSql = setNullableSql t colName colNullable --FIXME: allow setting default just for a while if necessary for this step. -- preguntar cuantos hay que tienen null ------------------------------------ -- Pretty printing SQL functions --- ------------------------------------ createTableSql :: String -> [(String,SqlColumnDesc,Maybe String)] -> String createTableSql t attrs = concat ["CREATE TABLE ", t, " (", intercalate ", " (map renderAttr attrs), ")" ] where renderAttr (name, coldesc, columnDefVal) = sqlAttributeDescription name coldesc columnDefVal addPrimaryKeySql :: String -> String addPrimaryKeySql t = "ALTER TABLE " ++ t ++ " ADD CONSTRAINT " ++ keyname ++ " PRIMARY KEY (id);" where keyname = t ++ "_pkey" addColumnSql :: String -> String -> SqlColumnDesc -> Maybe String -> String addColumnSql t colName coldesc columnDefVal = concat ["ALTER TABLE ", t, " ADD COLUMN ", sqlAttributeDescription colName coldesc columnDefVal, ";" ] renameColumnSql :: String -> String -> String -> String renameColumnSql t oldColName newColName = concat ["ALTER TABLE ", t, " RENAME ", oldColName, " TO ", newColName, ";" ] setDefaultSql :: String -> String -> Maybe String -> String setDefaultSql t colName columnDefVal = concat ["ALTER TABLE ", t, " ALTER COLUMN ", colName, setOrDrop columnDefVal, ";" ] where setOrDrop Nothing = " DROP DEFAULT" setOrDrop (Just defVal) = " SET DEFAULT " ++ defVal setNullableSql :: String -> String -> Bool -> String setNullableSql t colName nullable = concat ["ALTER TABLE ", t, " ALTER COLUMN ", colName, (if nullable then " DROP" else " SET"), " NOT NULL", ";" ] sqlAttributeDescription :: String -> SqlColumnDesc -> Maybe String -> String sqlAttributeDescription "id" _ _ = "id serial NOT NULL" sqlAttributeDescription colName (columnType, columnNullable) columnDefVal = concat [colName, " ", renderSqlTypeId columnType, renderNullable columnNullable, fromMaybe "" (fmap (" DEFAULT " ++) columnDefVal) ] where renderNullable True = "" renderNullable False = " NOT NULL" ------------------------------------------------- -- Automatic instance from type introspection --- ------------------------------------------------- instance (Data a, RelationalResource a) => CanCreateSchemaForResource a where -- userFieldsReps :: Proxy a -> [TypeRep] userFieldsReps pr = dropSystemReps (gmapQ typeOf (buildDummy pr)) where buildDummy :: Data a => Proxy a -> a buildDummy pr = fromConstr $ indexConstr (dataTypeOf (fromProxy pr)) 1 fromProxy :: Proxy a -> a fromProxy _ = undefined dropSystemReps :: [TypeRep] -> [TypeRep] dropSystemReps = if ownable pr then drop 2 else drop 1 -- FIXME: a different convention is used here. Here we consider that the key is the first one and the owner in case it exists, it is the snd one. In the rest of the framework we did not make assumption on the position, just on the names of the system fields. -- userFieldsDefaultValues :: Proxy a -> [Maybe String] -- default value sql expression userFieldsDefaultValues pr = repeat Nothing