> -- | High level model helpers > module Frame.Model ( > FrameIO, > FrameModel, > liftIO, > module Database.HaskellDB, > module Database.HaskellDB.BoundedList, > module Database.HaskellDB.BoundedString, > fieldName, > tableName, > (-.-), > run, > merge, > field, > posted, > wrapStringField, > wrapIntField, > wrapMaybeIntField, > wrapBoolField > ) where > import Database.HaskellDB > import Database.HaskellDB.HDBC.ODBC > import Database.HaskellDB.DBSpec.PPHelpers > import Database.HaskellDB.DBSpec.DBSpecToDBDirect > import Database.HaskellDB.BoundedList > import Database.HaskellDB.BoundedString > import Database.HaskellDB.Query (tableName, attributeName) > import Database.HaskellDB.DBLayout hiding (fieldName) > import Database.HaskellDB.PrimQuery > import Database.HaskellDB.Database > import Control.Monad.Trans > import Frame.Types > import Frame.Config > import Frame.State > import Frame.Validation > class (MonadIO m) => FrameIO m > instance (MonadIO m) => FrameIO m > class (FrameConfig m, FrameState m, FrameIO m) => FrameModel m > instance (FrameConfig m, FrameState m, FrameIO m) => FrameModel m > withODBC :: MonadIO m => String -> (Database -> m a) -> m a > withODBC u = (connect driver) [("DSN", u)] > -- | Convenience function for a stringed representation fo a table and attribute > ( -.- ) :: Table r -- ^ Table > -> Attr f a -- ^ Attribute > -> String -- ^ ''TableName.attributeName'' > t -.- a = fieldName (tableName t) $ attributeName a > -- | Convenience function for creating a qualified attribute name > fieldName :: String -- ^ Table name > -> String -- ^ Attribute name > -> String -- ^ ''TableName.attributeName'' > fieldName t f = t ++ "." ++ f > -- | Execute a database function against the DB > run :: FrameModel m  > => (Database -> m a) -- ^ The function that requires a database > -> m a -- ^ The executed result > run r = do > u <- asks dbURL > withODBC u r > -- | Take the fields updated by some model action and merge them in to the state > merge :: (FrameModel m) > => m (Maybe Fields) > -> m (Maybe Fields) > merge mr = do > mfs <- mr > mergeFields mfs > return mfs > field :: (Wrappable a) > => DBInfo > -> FieldName > -> a > -> (FieldName, WrapperType) > field d n f = (n, wrap d n f) > {-| > Should a form have been posted and all of the fields validate, run some > computation which maps fields to a model (with an empty return type) > -} > posted :: FrameModel m > => (Fields -> m a) -- ^ The computation to run > -> m Bool -- ^ Did the computation succeed? > posted f = do > db <- asks database > p <- gets post > fs <- gets fields > vs <- gets validators > case (p && allValidated vs fs) of > True -> do f $ purge db fs > return True > False -> return False > wrapStringField :: Size n => FieldName -> BoundedList Char n -> (FieldName, WrapperType) > wrapStringField fn b = (fn, WrapString (Just $ listBound b) $ fromBounded b) > wrapBoolField :: FieldName -> Bool -> (FieldName, WrapperType) > wrapBoolField fn v = (fn, WrapBool v) > wrapIntField :: FieldName -> Int -> (FieldName, WrapperType) > wrapIntField fn v = (fn, WrapInt v) > wrapMaybeIntField :: FieldName -> Maybe Int -> (FieldName, WrapperType) > wrapMaybeIntField fn (Just v) = wrapIntField fn v > wrapMaybeIntField fn Nothing = (fn, WrapEmpty IntT)