Some more types

Example.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE EmptyDataDecls #-}
 {-# LANGUAGE TypeFamilies #-}
-module Generics.Records.User where
+module Example where
 
 import Control.Applicative
 import Data.Maybe (fromJust)

Generics/Regular/Database.hs

@@ -36,17 +36,20 @@ new x = let v = gvalues x
                      [[i]] <- quickQueryS "SELECT last_insert_rowid() AS [ID]" []
                      return $ fromInteger $ fromSql i
 
-update :: (Regular a, Values a, GValues (PF a), GColumns (PF a), GModelName (PF a)) => a -> Int -> DB ()
-update x i = let v = values x
+update :: (Regular a, GValues (PF a), GColumns (PF a), GModelName (PF a)) => a -> Int -> DB ()
+update x i = let v = gvalues x
                  c = gtocolumns x
                  q = updateQuery (tableName $ from x) c
                   in case (length v == length c) of
                     False -> error "Incorrect instances for Values and Columns"
-                    True -> do quickQueryS q (v ++ [toSql i])
+                    True -> do liftIO (print q)
+                               liftIO $ print v
+                               quickQueryS q (v ++ [toSql i])
                                return ()
 
 find :: (Regular a, GParse (PF a), GColumns (PF a), GModelName (PF a), Show a) => a -> Int -> DB (Maybe a)
 find u i = do let q = findQuery (tableName $ from u) (gtocolumns u)
+              liftIO $ print q
               res <- map parse <$> (quickQueryS q [toSql i])
               case res of
                         []  -> return Nothing
@@ -55,7 +58,6 @@ find u i = do let q = findQuery (tableName $ from u) (gtocolumns u)
 
 findAll :: (Regular a, GParse (PF a), GColumns (PF a), GModelName (PF a), Show a) => a -> [(String, SqlValue)] -> DB [(Int, a)]
 findAll u w = do let q  = findAllQuery (tableName $ from u) ("id" : (gtocolumns u)) w
-                 liftIO $ print q
                  x <- (quickQueryS q $ map snd w)
                  return $ catMaybes $ map (evalState parse') x
     where parse' :: (Regular a, GParse (PF a)) => Parser (Int, a)
@@ -70,9 +72,12 @@ quickQueryS q v = get >>= \conn -> liftIO (quickQuery' conn q v)
 
 
 newQuery tableName columns = "INSERT INTO " ++ tableName ++ " (" ++ (intercalate ", " columns) ++ ") VALUES (" ++ (intercalate ", " $ map (const "?") columns) ++ ")"
-updateQuery tableName columns = "UPDATE " ++ tableName ++ " SET (" ++ (intercalate ", " columns) ++ ") VALUES (" ++ (intercalate ", " $ map (const "?") columns) ++ ") WHERE id = ?"
+updateQuery tableName columns = "UPDATE " ++ tableName ++ " SET " ++ (intercalate ", " changes) ++ " WHERE id = ?"
+                                                                                                                            where changes = map (++ " = ?") columns
+
 
 findQuery tableName columns = "SELECT " ++ (intercalate ", " columns) ++ " FROM " ++ tableName ++ " WHERE id = ? LIMIT 1"
 
-findAllQuery tableName columns fields = "SELECT " ++ (intercalate ", " columns) ++ " FROM " ++ tableName ++ " WHERE " ++ conds ++" LIMIT 1"
-  where conds = intercalate " AND " $ map ((++ " = ?") . fst) fields
+findAllQuery tableName columns fields = "SELECT " ++ (intercalate ", " columns) ++ " FROM " ++ tableName ++ (conds fields)
+  where conds []      = ""
+        conds (x:xs)  = "WHERE " ++ (intercalate " AND " $ map ((++ " = ?") . fst) (x:xs))

Generics/Regular/Database/Parse.hs

@@ -42,6 +42,9 @@ getOne = do x <- gets $ head' ("Database doesn't match defined schema.")
             modify tail
             return x
 
+getString :: Parser String
+getString = maybeRead <$> getOne
+
 parseUsingRead :: (Read a) => Parser a
 parseUsingRead = maybeRead <$> getOne
 

Generics/Regular/Formlets.hs

@@ -23,8 +23,8 @@ instance Formlet String where formlet = F.input
 class GFormlet f where
   gformf :: XFormlet a -> XFormlet (f a)
 
-gform :: (Regular a, GFormlet (PF a)) => XFormlet a
-gform x = to <$> (gformf gform (from <$> x))
+gformlet :: (Regular a, GFormlet (PF a)) => XFormlet a
+gformlet x = to <$> (gformf gformlet (from <$> x))
 
 instance (Constructor c, GFormlet f) => GFormlet (C c f) where
   gformf f x = C <$> (gformf f $ unC <$> x)
@@ -33,7 +33,7 @@ instance Formlet a => GFormlet (K a) where
   gformf _ x = K <$> (formlet (unK <$> x))
 
 instance (GFormlet f, GFormlet g) => GFormlet (f :*: g) where
-  gformf f x = (:*:) <$> (gformf f (prodFst <$> x)) <*> (gformf f (prodSnd <$> x))
+  gformf f x = (:*:) <$> (gformf f (prodFst <$> x)) <* F.xml X.br <*> (gformf f (prodSnd <$> x))
 
 
 instance (Selector s, GFormlet f) => GFormlet (S s f) where

Generics/Regular/Relations/HasMany.hs

@@ -27,6 +27,7 @@ instance Values    (HasMany a) where values _ = []
 
 -- Existential?
 data RHasMany a b = RHM { hmField  :: a -> HasMany b
+                        , hmForeignKey :: String
                         , hmUpdate :: a -> HasMany b -> a
                         }
 
@@ -37,19 +38,9 @@ fillHasMany :: ( Regular c, GParse (PF c), GColumns (PF c)
                    -> (RHasMany m c)
                    -> DB m
 fillHasMany u ix bt = case hmField bt u of
-                        HMNotFetched -> do rels <- findAll (hmType bt) [("user_id", toSql ix)]
+                        HMNotFetched -> do rels <- findAll (hmType bt) [(hmForeignKey bt, toSql ix)]
                                            return $ hmUpdate bt u $ HMFetched rels
-
-                         --HMNotFetched    -> error "fillBelongsTo"
-                         --HMNotFetched    -> do value <- find (fromBelongsTo $ btField bt u) x
-                         --                      let value' = fromMaybe' "fillBelongsTo" value
-                         --                      return $ btUpdate bt u $ BTFetched (x, value')
-                         --x@(BTFetched _) -> return $ btUpdate bt u x
--- where fromBelongsTo (BTFetched (x,y)) = y
---       fromBelongsTo _                 = error "fromBelongsTo"
-
---fromMaybe' e (Just x) = x
---fromMaybe' e _        = error e
+                        HMFetched _  -> return u
 
 hmType :: RHasMany m c -> c
 hmType = undefined

Generics/Regular/Views.hs

@@ -61,6 +61,34 @@ instance (Selector s, GHtml f) => GHtml (S s f) where
 ghtml :: (Regular a, GHtml (PF a)) => a -> X.Html
 ghtml x = ghtmlf ghtml (from x)
 
+
+class Table a where
+  table :: a -> X.Html
+
+class GTable f where
+  gtablef :: (a -> X.Html) -> f a -> X.Html
+
+instance GTable I where
+  gtablef f (I r) = f r
+
+instance (Constructor c, GTable f) => GTable (C c f) where
+  gtablef f cx@(C x) = X.tr << (gtablef f x)
+
+instance Html a => GTable (K a) where
+  gtablef _ (K x) = html x
+
+instance (GTable f, GTable g) => GTable (f :*: g) where
+  gtablef f (x :*: y) = gtablef f x +++ gtablef f y
+
+instance (Selector s, GTable f) => GTable (S s f) where
+  gtablef f s@(S x) = X.td << gtablef f x
+
+gtableRow :: (Regular a, GTable (PF a)) => a -> X.Html
+gtableRow x = gtablef gtableRow (from x)
+
+gtable :: (Regular a, GTable (PF a)) => [a] -> X.Html
+gtable xs = X.table << map gtableRow xs
+
 -- JSON stuff
 
 --class Json a where

Generics/Regular/WebTypes.hs

@@ -0,0 +1,28 @@
+module Generics.Regular.WebTypes where
+
+import Control.Applicative
+import Database.HDBC (toSql)
+import Generics.Regular
+import Generics.Regular.Database.Parse
+import Generics.Regular.Database.Columns
+import Generics.Regular.Database.Values
+import Generics.Regular.Views
+import Generics.Regular.Formlets
+import qualified Text.XHtml.Strict as X
+import qualified Text.XHtml.Strict.Formlets as F
+
+newtype Password = Password {unpass :: String} deriving Show
+
+instance ParseSql Password where parsef = fmap Password <$> getString
+instance Columns  Password where columns   = const keep
+instance Values   Password where values    = return . toSql . unpass
+instance Html     Password where html      = const X.noHtml
+instance Formlet  Password where formlet x = Password <$> F.password (unpass <$> x)
+
+--newtype Textarea = Textarea {untextarea :: String} deriving Show
+--
+--instance ParseSql Textarea where parsef    = fmap Textarea <$> getString
+--instance Columns  Textarea where columns   = const keep
+--instance Values   Textarea where values    = return . toSql . untextarea
+--instance Html     Textarea where html      = const X.noHtml
+--instance Formlet  Textarea where formlet x = Textarea <$> F.textarea (untextarea <$> x)

Happstack.hs

@@ -0,0 +1,139 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Example where
+
+import Control.Applicative
+import Control.Applicative.Error
+import Control.Applicative.State
+import Text.Formlets
+import qualified Text.XHtml.Strict.Formlets as F
+import qualified Text.XHtml.Strict as X
+import Text.XHtml.Strict ((+++), (<<))
+import Happstack.Server
+import Generics.Regular
+import Generics.Regular.Formlets hiding (XFormlet)
+import Generics.Regular.Database
+import Generics.Regular.ModelName
+import Generics.Regular.Views
+import Generics.Regular.Relations
+import Generics.Regular.WebTypes
+import Database.HDBC.Sqlite3 (Connection, connectSqlite3)
+import Database.HDBC (commit)
+
+data User = User {name :: String, password :: Password, age :: Int} deriving Show
+data Post = Post {title :: String, body :: String, author :: BelongsTo User} deriving Show
+
+$(deriveAll ''User "PFUser")
+type instance PF User = PFUser
+
+$(deriveAll ''Post "PFPost")
+type instance PF Post = PFPost
+
+data TW a
+
+mainHandler =   dir "user" (crudHandler (undefined :: TW User))
+        `mplus` dir "post" (crudHandler (undefined :: TW Post))
+
+-- generic CRUD
+
+crudHandler :: (Regular a, GHtml (PF a), GFormlet (PF a), GTable (PF a), GValues (PF a), GColumns (PF a), GModelName (PF a), GParse (PF a), Show a) 
+            => TW a -> ServerPartT IO Response
+crudHandler tw = create tw
+       `mplus` (dir "view" $ uriRest (handleRead tw))
+       `mplus` (dir "edit" $ uriRest (handleEdit tw))
+       `mplus` (dir "list" (handleList tw))
+
+-- DB stuff
+db d = liftIO $ do conn <- connectSqlite3 "happstack.sqlite3"
+                   x <- runDB conn d
+                   commit conn
+                   return x
+
+-- CRUD things
+--
+handleList :: (Regular a, GTable (PF a), GValues (PF a), GColumns (PF a), GModelName (PF a), GParse (PF a), Show a) 
+           => TW a -> ServerPartT IO Response
+handleList tw  = do x <- db $ findAll (unTw tw) []
+                    okHtml $ gtable $ map snd x
+            where unTw = undefined :: TW a -> a
+
+handleRead :: (Regular a, GHtml (PF a), GValues (PF a), GColumns (PF a), GModelName (PF a), GParse (PF a), Show a) 
+           => TW a -> String -> ServerPartT IO Response
+handleRead tw (x:xs) = do x <- liftIO $ findDB tw (read xs)
+                          okHtml $ maybe X.noHtml ghtml x
+
+findDB :: (Regular a, GValues (PF a), GColumns (PF a), GModelName (PF a), GParse (PF a), Show a) 
+       => TW a -> Int -> IO (Maybe a)
+findDB tw i = do x <- db $ find (unTw tw) i
+                 return x
+            where unTw = undefined :: TW a -> a
+
+handleEdit :: (Regular a, GFormlet (PF a), GValues (PF a), GColumns (PF a), GModelName (PF a), GParse (PF a), Show a) 
+       => TW a -> String -> ServerPartT IO Response
+handleEdit tw (x:xs) = do let i = read xs
+                          user <- liftIO $ findDB tw i
+                          liftIO $ print user
+                          withForm Nothing (mkForm tw user) showErrorsInline (editDB i)
+
+editDB :: (Regular a, GFormlet (PF a), GValues (PF a), GColumns (PF a), GModelName (PF a), Show a) 
+       => Int -> a -> ServerPartT IO Response
+editDB i x = do db (update x i)
+                okHtml "Item updated."
+
+create :: (Regular a, GFormlet (PF a), GValues (PF a), GColumns (PF a), GModelName (PF a), Show a) 
+       => TW a -> ServerPartT IO Response
+create tw = withForm (Just "create") (mkForm tw Nothing) showErrorsInline createDb
+
+createDb x = do ix <- db $ new x
+                okHtml $ show ix ++ " is successfully registered"
+
+mkForm :: (Regular a, GFormlet (PF a)) => TW a -> XFormlet a
+mkForm tw = gformlet
+
+
+-- Happstack specific stuff
+type XFormlet a = F.XHtmlFormlet a
+type XForm a = F.XHtmlForm a
+
+htmlPage :: (X.HTML a) => a -> X.Html
+htmlPage content = (X.header << (X.thetitle << "Testing forms"))
+ +++ (X.body << content)
+
+okHtml :: (X.HTML a) => a -> ServerPartT IO Response
+okHtml content = ok $ toResponse $ htmlPage $ content
+
+withForm :: Maybe String -> XForm a -> (X.Html -> [String] -> ServerPartT IO Response) -> (a -> ServerPartT IO Response) -> ServerPartT IO Response 
+withForm name frm handleErrors handleOk = maybe id dir name $ msum
+ [ anyPath $ methodSP GET $ createForm [] frm >>= okHtml
+ , anyPath $ withDataFn lookPairs $ \d ->
+     methodSP POST $ handleOk' $ simple d
+ ]
+ where
+   handleOk' d = do
+     let (extractor, html, _) = runFormState d frm
+     let v = extractor  
+     case v of
+       Failure faults -> do 
+         f <- createForm d frm
+         handleErrors f faults
+       Success s      -> handleOk s
+   simple d = map (\(k,v) -> (k, Left v)) d
+
+showErrorsInline :: X.Html -> [String] -> ServerPartT IO Response
+showErrorsInline renderedForm errors =
+ okHtml $ X.toHtml (show errors) +++ renderedForm
+
+createForm :: Env -> XForm a -> ServerPartT IO X.Html
+createForm env frm = do
+ let (extractor, xml, endState) = runFormState env frm
+ return $ X.form X.! [X.method "POST"] << (xml +++ X.br +++ X.submit "submit" "Submit")
+
+label :: String -> XForm String -> XForm String
+label l = F.plug (\xhtml -> X.p << (X.label << (l ++ ": ") +++ xhtml))
+
+port_ = 9959
+
+main = do print $ ("running at port", port_)
+          simpleHTTP (nullConf {port = port_}) mainHandler