>
> 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)]
>
> ( -.- ) :: Table r
> -> Attr f a
> -> String
> t -.- a = fieldName (tableName t) $ attributeName a
>
> fieldName :: String
> -> String
> -> String
> fieldName t f = t ++ "." ++ f
>
> run :: FrameModel m> => (Database -> m a)
> -> m a
> run r = do
> u <- asks dbURL
> withODBC u r
>
> 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)
>
> posted :: FrameModel m
> => (Fields -> m a)
> -> m Bool
> 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)