simple 0.4.1 → 0.5.0

raw patch · 17 files changed

+916/−1149 lines, 17 filesdep +directorydep +filepathdep +hashtablesdep −hintdep −mtldep −networkdep ~attoparsecdep ~basedep ~base64-bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: directory, filepath, hashtables, monad-peel, process, stringsearch

Dependencies removed: hint, mtl, network, old-locale, old-time, postgresql-simple, resource-pool, resourcet, system-fileio, system-filepath, wai-handler-devel

Dependency ranges changed: attoparsec, base, base64-bytestring, bytestring, cmdargs, conduit, http-types, text, transformers, wai, wai-extra

API changes (from Hackage documentation)

Files

• Database/PostgreSQL/Connection.hs +0/−58
• Database/PostgreSQL/Migrations.hs +0/−58
• Database/PostgreSQL/Models.hs +0/−267
• Database/PostgreSQL/Sequel.hs +0/−129
• Web/Frank.hs +11/−12
• Web/REST.hs +49/−54
• Web/Simple.hs +249/−3
• Web/Simple/Auth.hs +43/−36
• Web/Simple/Cache.hs +86/−0
• Web/Simple/Controller.hs +362/−98
• Web/Simple/Migrations.hs +0/−27
• Web/Simple/Responses.hs +5/−3
• Web/Simple/Router.hs +0/−239
• simple.cabal +44/−69
• smpl.hs +32/−96
• template/Main_hs.tmpl +17/−0
• template/package_cabal.tmpl +18/−0

@@ -1,58 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-module Database.PostgreSQL.Connection where--import Data.Pool-import Control.Monad.IO.Class-import Control.Monad.Trans.Resource-import Database.PostgreSQL.Simple-import Network.URI-import System.IO.Unsafe-import System.Environment--{-# NOINLINE conns #-}-conns :: Pool Connection-conns = unsafePerformIO $ do-  dbUrl <- getEnv "DATABASE_URL"-  let creator = createConnection $ parseDbURL dbUrl-  createPool creator-             (\c -> rollback c >> close c)-             1-             (fromInteger 60)-             20--createConnection :: ConnectInfo -> IO Connection-createConnection config = connect config--parseDbURL :: String -> ConnectInfo-parseDbURL uri = case mdbURI of-    Nothing -> defaultConnectInfo-    Just dbURI | uriScheme dbURI == "postgres:" ->-      let auth = uriAuthority dbURI-      in ConnectInfo { connectPort = toPort auth-                  , connectHost = toHostname auth-                  , connectUser = toUsername auth-                  , connectPassword = toPassword auth-                  , connectDatabase = toDatabase . uriPath $ dbURI}-      | otherwise -> defaultConnectInfo-  where mdbURI = parseURI uri-        toPort (Just (URIAuth _ _ "")) = 5432-        toPort (Just (URIAuth _ _ (':':p))) = read p-        toPort _ = 5432-        toHostname (Just (URIAuth _ h _)) = h-        toHostname _ = "localhost"-        toUsername (Just (URIAuth ua _ _)) = takeWhile (\x -> x /= ':' && x /= '@') ua-        toUsername Nothing = ""-        toPassword (Just (URIAuth ua _ _)) = case dropWhile (/= ':') ua of-                                               (':':password) -> takeWhile (/= '@') password-                                               _ -> ""-        toPassword Nothing = ""-        toDatabase ('/':db) = db-        toDatabase _ = ""--withConnection :: (MonadIO m, MonadBaseControl IO m) => (Connection -> m b) -> m b-withConnection func = withResource conns $ \conn -> do-  liftIO $ begin conn-  res <- func conn-  liftIO $ commit conn-  return res-

@@ -1,58 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Database.PostgreSQL.Migrations-  ( runDb, dbUp, dbDown, initDb-  , module Database.PostgreSQL.Sequel-  ) where--import Prelude-import Control.Monad.IO.Class (liftIO)-import Database.PostgreSQL.Connection-import Database.PostgreSQL.Sequel-import Database.PostgreSQL.Simple-import Web.Simple.Migrations--runDb :: Sequel a -> IO a-runDb act = withConnection $ \conn -> runSequel act conn--dbUp :: Sequel a -> Migration-dbUp act version name = runDb $ do-  (Only count:_) <--    sqlQuery "select count(version) from schema_migrations where version = ?"-              [version]-  if (count :: Int) > 0 then-    return False-    else do-          liftIO $ putStrLn $-            "=== Running migration: " ++ name ++ " (" ++ version ++ ")"-          act-          sqlExecute "insert into schema_migrations (version) values(?)"-                     (Only version)-          return True--dbDown :: Sequel a -> Migration-dbDown act version name = runDb $ do-  (Only count:_) <--    sqlQuery "select count(version) from schema_migrations where version = ?"-              [version]-  if (count :: Int) == 0 then-    return False-    else do-          liftIO $ putStrLn $-            "=== Rolling back: " ++ name ++ " (" ++ version ++ ")"-          act-          sqlExecute "delete from schema_migrations where version = ?"-                     (Only version)-          return True--initDb :: Migration-initDb _ _ = runDb $ do-  (Only count:_) <- sqlQuery "select count(*) from pg_class where relname = ?"-                      (Only ("schema_migrations" :: String))-  if (count :: Int) /= 0 then-    return False-    else do-          liftIO $ putStrLn "Creating table `schema_migrations`"-          create_table "schema_migrations" $-            column "version" string [UNIQUE]-          return True-

@@ -1,267 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts #-}-{- |--Type classes for PostgreSQL-backed data models.---}--module Database.PostgreSQL.Models-  ( FromParams(..), Param-  , PostgreSQLModel(..)-  , HasMany(..)-  , TableName(..), fromTableName-  , fromString, IsString-  ) where--import Data.List (intersperse)-import Data.String-import Database.PostgreSQL.Simple-import Database.PostgreSQL.Simple.ToField-import Database.PostgreSQL.Simple.ToRow-import Database.PostgreSQL.Simple.FromField-import Network.Wai.Parse--class FromParams p where-  -- | Converts an HTML form into a type-  fromParams :: [Param] -> Maybe p--instance (FromParams a, FromParams b) => FromParams (a, b) where-  fromParams params = do-    a <- fromParams params-    b <- fromParams params-    return (a, b)---- | Wrapper type representing PostgreSQL table names-newtype TableName p = TableName String deriving (Show, Eq)---- | Unwraps a 'TableName'-fromTableName :: TableName p -> String-fromTableName (TableName s) = s---- | Basis type for PostgreSQL-backed data-models. Instances must, at minimum,--- implement 'primaryKey', 'tableName' and 'columns'. /Note: the column ordering--- must match that used in the type's implementation of 'FromRow' and 'ToRow'/-class (FromRow p, ToRow p, ToField (PrimaryKey p), FromField (PrimaryKey p))-  => PostgreSQLModel p where--  type PrimaryKey p :: *--  -- | Given a model, returns the value of it's primary key. In many cases, this-  -- will simply be an alias to a record accessor.-  primaryKey :: p -> Maybe (PrimaryKey p)--  -- | Returns the 'TableName' of the model. Instances should have a top-level value-  -- for the 'TableName' that is always returned. For example:-  ---  -- > employees :: TableName Employee-  -- > employees = TableName "employees"-  -- >-  -- > instance PostgreSQLModel Employee where-  -- >   ...-  -- >   tableName _ = employess-  -- -  tableName :: p -> TableName p--  -- | Column names excluding primary key. Column order /must/ match the ordering-  -- used in 'ToRow' and 'FromRow'.-  columns :: TableName p -> [String]--  -- | Name of primary key column (default: \"id\").-  primaryKeyName :: TableName p -> String-  primaryKeyName _ = "id"--  -- | Column names with primary-key name prepended.-  columns_ :: TableName p -> [String]-  columns_ tName = (primaryKeyName tName):(columns tName)--  orderBy :: TableName p -> Maybe String-  orderBy _ = Nothing--  -- | Inserts the model into the database. It relies on the primary key-  -- being autogenerated by the database.-  insert :: p -> Connection -> IO (PrimaryKey p)-  insert model conn = do-    query conn template fields >>= return . head . head-    where template = fromString $ concat-            [ "insert into " -            , fromTableName tName-            , " (" ++ cols ++ ")"-            , " VALUES (" ++ qs ++ ") RETURNING "-            , primaryKeyName tName]-          tName = tableName model-          qs = concat $ intersperse ", " $ map (const "?") $ colNames-          cols = concat $ intersperse ", " $ colNames-          colNameFields = case primaryKey model of-                            Nothing -> (columns tName, toRow model)-                            Just pkey -> ( columns_ tName-                                         , (toField pkey):(toRow model))-          (_, fields) = colNameFields-          (colNames, _) = colNameFields-  -  -- | Create or update the model (uses the primary key to determine if-  -- the model already exists in the database)-  upsert :: p -> Connection -> IO (PrimaryKey p)-  upsert model conn = do-    case primaryKey model of-      Nothing -> insert model conn-      Just pkey -> do-        execute conn template $ toRow model ++ [toField pkey]-        return pkey-    where template = fromString $ concat-            ["update "-            , fromTableName tName-            , " SET "-            , cols, " where ", primaryKeyName tName-            , " = ?"]-          tName = tableName model-          cols = concat $ intersperse ", " $ map (++ " =?") (columns tName)--  destroy :: p -> Connection -> IO Bool-  destroy model conn = do-    case primaryKey model of-      Nothing -> return False-      Just pkey -> do-        fmap (> 0) $ execute conn template (Only pkey)-    where template = fromString $ concat-            [ "delete from "-            , fromTableName tName-            , " where "-            , primaryKeyName tName-            , " = ?;"]-          tName = tableName model--  -- | Retrieves the single model corresponding to the given primary key-  find :: TableName p -> PrimaryKey p -> Connection -> IO (Maybe p)-  find tn = findFirst tn (primaryKeyName tn)--  -- | Finds the first model in the database based on the column-value contstraint.-  findFirst :: ToField f-            => TableName p-            -> String -- ^ Search column name-            -> f -- ^ Search value-            -> Connection -> IO (Maybe p)-  findFirst tName col val conn = do-    models <- query conn template (Only val)-    case models of-      (model:_) -> return $ Just model-      [] -> return Nothing-    where template = fromString $ concat-            ["select ", cols, " from "-            , fromTableName tName-            , " where "-            , col-            , " = ?"-            , maybe "" (" order by " ++) $ orderBy tName-            , " limit 1"]-          cols = concat $ intersperse ", " $ columns_ tName--  -- | Retrieves all models in the table-  findAll :: TableName p -> Connection -> IO [p]-  findAll tName conn = query_ conn template-    where template = fromString $ concat -            [ "select ", cols, " from "-            , fromTableName tName-            , maybe "" (" order by " ++) $ orderBy tName]-          cols = concat $ intersperse ", " $ columns_ tName--  -- | Retrieves all models in the table subject to the column-value constraint.-  findAllBy :: ToField f-            => TableName p-            -> String -- ^ Search column name-            -> f -- ^ Search value-            -> Connection -> IO [p]-  findAllBy tName col val conn = query conn template (Only val)-    where template = fromString $ concat -            [ "select ", cols, " from "-            , fromTableName tName-            , " where ", col, " = ?"-            , maybe "" (" order by " ++) $ orderBy tName]-          cols = concat $ intersperse ", " $ columns_ tName---- | Defines a \"has-many\" relationship between two models, where the 'parent'--- model may be associated with zero or more of the 'child' model. Specifically,--- the 'child' table has a foreign key column pointing to the parent model.-class (PostgreSQLModel parent, PostgreSQLModel child) =>-  HasMany parent child where-  -  foreignKey :: TableName parent -> TableName child -> String-  foreignKey tName _ = fromTableName tName ++ "_" ++ (primaryKeyName tName)--  childrenOf :: parent -> TableName child -> Connection -> IO [child]-  childrenOf parent ctName conn = query conn template (Only $ primaryKey parent)-    where template = fromString $ concat $-            [ "select ", childColumns, " from "-            , fromTableName ctName-            , " where "-            , foreignKey ptName ctName-            , " = ?"-            , maybe "" (" order by " ++) $ orderBy ctName]-          ptName = tableName parent-          childColumns = concat $ intersperse ", " $ columns_ ctName--  childOf :: parent -> TableName child-          -> PrimaryKey child -> Connection -> IO (Maybe child)-  childOf parent ctName v = childOfBy parent ctName (primaryKeyName ctName) v--  childOfBy :: ToField v-          => parent-          -> TableName child-          -> String-          -> v-          -> Connection -> IO (Maybe child)-  childOfBy parent ctName col pkeyc conn = do-    mchildren <- query conn template (primaryKey parent, pkeyc) -    case mchildren of-      [] -> return Nothing-      (c:_) -> return $ Just c-    where template = fromString $ concat $-            [ "select ", childColumns, " from "-            , fromTableName ctName-            , " where "-            , foreignKey ptName ctName, " = ?"-            , " and ", col, " = ?"-            , maybe "" (" order by " ++) $ orderBy ctName-            , " limit 1"]-          ptName = tableName parent-          childColumns = concat $ intersperse ", " $ columns_ ctName--  childrenOfBy :: ToField f-             => parent-             -> TableName child-             -> String-             -> f-             -> Connection -> IO [child]-  childrenOfBy parent ctName col val conn =-    query conn template (primaryKey parent, val)-    where template = fromString $ concat $-            [ "select ", childColumns, " from "-            , fromTableName ctName-            , " where "-            , foreignKey ptName ctName-            , " = ? and ", col, " = ?"-            , maybe "" (" order by " ++) $ orderBy ctName]-          ptName = tableName parent-          childColumns = concat $ intersperse ", " $ columns_ ctName--  insertFor :: parent -> child -> Connection -> IO (PrimaryKey child)-  insertFor parent chld conn = do-    query conn template (fields ++ [toField $ primaryKey parent])-      >>= return . head . head-    where template = fromString $ concat-            [ "insert into " -            , fromTableName ctName-            , " (", cols, ", ", foreignKey ptName ctName, ")"-            , " VALUES (", qs, ", ?) "-            , " RETURNING "-            , primaryKeyName ctName]-          ctName = tableName chld-          ptName = tableName parent-          qs = concat $ intersperse ", " $ map (const "?") $ colNames-          cols = concat $ intersperse ", " $ colNames-          colNameFields = case primaryKey chld of-                            Nothing -> (columns ctName, toRow chld)-                            Just pkey -> ( columns_ ctName-                                         , (toField pkey):(toRow chld))-          (_, fields) = colNameFields-          (colNames, _) = colNameFields-

@@ -1,129 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Database.PostgreSQL.Sequel where--import Database.PostgreSQL.Simple-import Control.Monad.Identity-import Control.Monad.State-import Data.List-import Data.String--data Sequel a = Sequel { runSequel :: Connection -> IO a }--instance Monad Sequel where-  return a = Sequel $ const $ return a-  (>>=) (Sequel run) f = Sequel $ \conn ->-    run conn >>= \res -> runSequel (f res) conn--instance MonadIO Sequel where-  liftIO = Sequel . const--drop_table :: String -> Sequel ()-drop_table name = sqlExecute_ (fromString $ "DROP TABLE " ++ name ++ ";")--create_table :: String -> CreateTable a -> Sequel ()-create_table name block = do-  let blk = runCreateTable block-  let execStr = fromString $ concat $-            [ "CREATE TABLE "-            , name-            , " (\n"-            , blk-            , "\n);"]-  sqlExecute_ execStr--type ColumnType = String--serial :: ColumnType-serial = "serial"--integer :: ColumnType-integer = "integer"--time :: ColumnType-time = "time"--timestamp :: ColumnType-timestamp = "timestamptz"--varchar :: Integer -> ColumnType-varchar size = "varchar(" ++ (show size) ++ ")"--string :: ColumnType-string = varchar 255--text :: ColumnType-text = "text"--boolean :: ColumnType-boolean = "boolean"--data ColumnConstraint = NOT_NULL-                      | UNIQUE-                      | PRIMARY_KEY-                      | DEFAULT String-                      | REFERENCES String String--stringifyConstraint :: ColumnConstraint -> String-stringifyConstraint NOT_NULL = "NOT NULL"-stringifyConstraint UNIQUE = "UNIQUE"-stringifyConstraint PRIMARY_KEY = "PRIMARY KEY"-stringifyConstraint (DEFAULT str) = "DEFAULT " ++ str-stringifyConstraint (REFERENCES table col) =-  "REFERENCES " ++ table ++ "(" ++ col ++ ")"--drop_column :: String -> String -> Sequel ()-drop_column tableName colName = sqlExecute_ $ fromString $ concat-    ["ALTER TABLE "-    , tableName-    , " DROP COLUMN "-    , colName-    , ";"]--add_column :: String -> String -> ColumnType -> [ColumnConstraint] -> Sequel ()-add_column tableName colName colType ctrs = sqlExecute_ $ fromString $ concat-  [ "ALTER TABLE "-  , tableName-  , " ADD COLUMN "-  , colName-  , " "-  , colType-  , " "-  , concat $ intersperse " " (map stringifyConstraint ctrs), ";"]--rename_column :: String -> String -> String -> Sequel ()-rename_column tableName fromName toName = sqlExecute_ $ fromString $ concat-  [ "ALTER TABLE "-  , tableName-  , " RENAME COLUMN "-  , fromName-  , " TO "-  , toName, ";"]--type CreateTable = StateT [(ColumnType, String, [ColumnConstraint])] Identity--runCreateTable :: CreateTable a -> String-runCreateTable ct = runIdentity $ do-  (_, cols) <- runStateT ct []-  let colStrs = map-        (\(t, name, crts) ->-            "  " ++ name ++ " " ++ t ++ " " ++-            (concat $ intersperse " " (map stringifyConstraint crts))-        ) cols-  return $ concat $ intersperse ",\n" (reverse colStrs)--column :: String -> ColumnType -> [ColumnConstraint] -> CreateTable ()-column colName colType constraints = do-  modify $ \cols -> (colType, colName, constraints):cols--sqlQuery :: (ToRow q, FromRow r) => Query -> q -> Sequel [r]-sqlQuery myq params = Sequel $ \conn -> query conn myq params--sqlQuery_ :: FromRow r => Query -> Sequel [r]-sqlQuery_ myq = Sequel $ \conn -> query_ conn myq--sqlExecute :: ToRow q => Query -> q -> Sequel ()-sqlExecute myq params = Sequel $ \conn -> execute conn myq params >> return ()--sqlExecute_ :: Query -> Sequel ()-sqlExecute_ myq = Sequel $ \conn -> execute_ conn myq >> return ()-

@@ -1,13 +1,13 @@ {- | Frank is a Sinatra-inspired DSL (see <http://www.sinatrarb.com>) for creating-routes. It is composable with all 'Routeable' types, but is designed to be used+routes. It is composable with all 'ToApplication' types, but is designed to be used with 'Network.Wai.Controller's. Each verb ('get', 'post', 'put', etc') takes a URL pattern of the form \"\/dir\/:paramname\/dir\" (see 'routePattern' for-details) and a 'Routeable':+details) and a 'ToApplication':  @   main :: IO ()-  main = runSettings defaultSettings $ mkRouter $ do+  main = run 3000 $ controllerApp () $ do     get \"\/\" $ do       req <- request       return $ okHtml $ fromString $@@ -30,30 +30,29 @@   ) where  import Network.HTTP.Types-import Web.Simple.Router+import Web.Simple.Controller import qualified Data.ByteString as S  -- | Helper method-frankMethod :: Routeable r => StdMethod -> S.ByteString -> r -> Route ()-frankMethod method pattern = routeMethod method . routePattern pattern+frankMethod :: StdMethod -> S.ByteString -> Controller r a -> Controller r ()+frankMethod method pattern = routeMethod method . routePattern pattern . routeTop  -- | Matches the GET method on the given URL pattern-get :: Routeable r => S.ByteString -> r -> Route ()+get :: S.ByteString -> Controller r a -> Controller r () get = frankMethod GET  -- | Matches the POST method on the given URL pattern-post :: Routeable r => S.ByteString -> r -> Route ()+post :: S.ByteString -> Controller r a -> Controller r () post = frankMethod POST  -- | Matches the PUT method on the given URL pattern-put :: Routeable r => S.ByteString -> r -> Route ()+put :: S.ByteString -> Controller r a -> Controller r () put = frankMethod PUT  -- | Matches the DELETE method on the given URL pattern-delete :: Routeable r => S.ByteString -> r -> Route ()+delete :: S.ByteString -> Controller r a -> Controller r () delete = frankMethod DELETE  -- | Matches the OPTIONS method on the given URL pattern-options :: Routeable r => S.ByteString -> r -> Route ()+options :: S.ByteString -> Controller r a -> Controller r () options = frankMethod OPTIONS-

@@ -1,92 +1,87 @@ {-# LANGUAGE FlexibleInstances, OverloadedStrings #-} module Web.REST-  ( REST(..), RESTController, rest+  ( REST(..), RESTController, rest, routeREST   , index, show, create, update, delete   , edit, new   ) where  import Prelude hiding (show) +import Control.Monad import Control.Monad.Trans.State-import Control.Monad.Identity+import Data.Functor.Identity import Web.Simple.Responses-import Web.Simple.Router+import Web.Simple.Controller import Network.HTTP.Types -data REST = REST-  { restIndex   :: Route ()-  , restShow    :: Route ()-  , restCreate  :: Route ()-  , restUpdate  :: Route ()-  , restDelete  :: Route ()-  , restEdit    :: Route ()-  , restNew     :: Route ()+data REST r = REST+  { restIndex   :: Controller r ()+  , restShow    :: Controller r ()+  , restCreate  :: Controller r ()+  , restUpdate  :: Controller r ()+  , restDelete  :: Controller r ()+  , restEdit    :: Controller r ()+  , restNew     :: Controller r ()   } -defaultREST :: REST+defaultREST :: REST r defaultREST = REST-  { restIndex   = routeAll $ notFound-  , restShow    = routeAll $ notFound-  , restCreate  = routeAll $ notFound-  , restUpdate  = routeAll $ notFound-  , restDelete  = routeAll $ notFound-  , restEdit    = routeAll $ notFound-  , restNew     = routeAll $ notFound+  { restIndex   = respond $ notFound+  , restShow    = respond $ notFound+  , restCreate  = respond $ notFound+  , restUpdate  = respond $ notFound+  , restDelete  = respond $ notFound+  , restEdit    = respond $ notFound+  , restNew     = respond $ notFound   } -instance Routeable REST where-  runRoute controller = runRoute $ do-    routeMethod GET $ do-      routeTop $ restIndex controller-      routeName "new" $ restNew controller-      routeVar "id" $ do-        routeTop $ restShow controller-        routeName "edit" $ restEdit controller--    routeMethod POST $ routeTop $ restCreate controller+type RESTControllerM r a = StateT (REST r) Identity a -    routeMethod DELETE $ routeVar "id" $ restDelete controller+rest :: RESTControllerM r a -> REST r+rest rcontroller = snd . runIdentity $ runStateT rcontroller defaultREST -    routeMethod PUT $ routeVar "id" $ restUpdate controller+routeREST :: REST r -> Controller r ()+routeREST rst = do+  routeMethod GET $ do+    routeTop $ restIndex rst+    routeName "new" $ restNew rst+    routeVar "id" $ do+      routeTop $ restShow rst+      routeName "edit" $ restEdit rst -type RESTControllerM a = StateT REST Identity a+  routeMethod POST $ routeTop $ restCreate rst -instance Routeable (RESTControllerM a) where-  runRoute controller = rt-    where rt req = do-            let (_, st) = runIdentity $ runStateT controller defaultREST-            runRoute st req+  routeMethod DELETE $ routeVar "id" $ restDelete rst -rest :: RESTControllerM a -> REST-rest controller = snd . runIdentity $ runStateT controller defaultREST+  routeMethod PUT $ routeVar "id" $ restUpdate rst -type RESTController = RESTControllerM ()+type RESTController r = RESTControllerM r () -index :: Routeable r => r -> RESTController+index :: Controller r a -> RESTController r index route = modify $ \controller ->-  controller { restIndex = routeAll route }+  controller { restIndex = void route } -create :: Routeable r => r -> RESTController+create :: Controller r a -> RESTController r create route = modify $ \controller ->-  controller { restCreate = routeAll route }+  controller { restCreate = void route } -edit :: Routeable r => r -> RESTController+edit :: Controller r a -> RESTController r edit route = modify $ \controller ->-  controller { restEdit = routeAll route }+  controller { restEdit = void route } -new :: Routeable r => r -> RESTController+new :: Controller r a -> RESTController r new route = modify $ \controller ->-  controller { restNew = routeAll route }+  controller { restNew = void route } -show :: Routeable r => r -> RESTController+show :: Controller r a -> RESTController r show route = modify $ \controller ->-  controller { restShow = routeAll route }+  controller { restShow = void route } -update :: Routeable r => r -> RESTController+update :: Controller r a -> RESTController r update route = modify $ \controller ->-  controller { restUpdate = routeAll route }+  controller { restUpdate = void route } -delete :: Routeable r => r -> RESTController+delete :: Controller r a -> RESTController r delete route = modify $ \controller ->-  controller { restDelete = routeAll route }+  controller { restDelete = void route } 

@@ -1,10 +1,256 @@+{- |+++/Simple/ is based on WAI - an standard interface for communicating between web+servers (like warp) and web applications. You can use /Simple/ completely+independently (and of course, use any WAI server to run it). Alternatively, you+can embed existing existing WAI applications inside an app built with /Simple/,+and embed an app built with simple in another WAI app.++All the components in /Simple/ are designed to be small and simple+enough to understand, replaceable, and work as well independantly as they do+together.++-} module Web.Simple (-    module Web.Simple.Router-  , module Web.Simple.Responses+    module Web.Simple.Responses   , module Web.Simple.Controller+  -- * Overview+  -- $Overview++  -- * Tutorial+  -- $Tutorial++  -- ** Controllers+  -- $Controllers++  -- ** Routing+  -- $Routing   ) where -import Web.Simple.Router import Web.Simple.Responses import Web.Simple.Controller++{- $Overview+ #overview#++WAI applications are functions of type 'Network.Wai.Application' - given a+client 'Network.Wai.Request' they return a 'Network.Wai.Response' to return to+the client (i.e. an HTTP status code, headers, body etc\'). A /Simple/+application 'Controller' -- a wrapper around WAI\'s 'Network.Wai.Application'+either returns a monadic value, or a 'Network.Wai.Response'. This allows+'Controller's to be chained together to create arbitrary complex routes. If a+'Controller' \"matches\" a route (e.g., based on the HTTP path, hostname,+cookies etc), it can 'respond' which shortcircuits the remaining execution and+immediately send the response back to the client. If none, of the 'Controller's+match, an HTTP 404 (NOT FOUND) response will be returned.++For example, this is a trivial \Simple\ app that notices whether the incoming+request was for the hostname \"hackage.haskell.org\" or \"www.haskell.org\":++@+  routeHost \"hackage.haskell.org\" $ do+    respond $ okHtml \"Welcome to Hackage\"++  routeHost \"www.haskell.org\" $ do+    respond $ okHtml \"You\'ve reached the Haskell Language home page\"+@++'routeHost' is a combinator that matches the a request based on the \"Host\"+header and defers to the passed in 'Controller' or returns '()'. There are+other built-in combinators for matching based on the request path, the HTTP+method, and it\'s easy to write your own combinators. You can chain such+combinators together monadically or using 'mappend' (since 'Controller' is an+instance of 'Monoid'). A typical /Simple/ app looks something like this:++@+  controllerApp () $ do+    routeTop $ do+      ... handle home page ...+    routeName \"posts\" $ do+      routeMethod GET $+        ... get all posts ...+      routeMethod POST $+        ... create new post ...+@++where 'controllerApp' generates an 'Network.Wai.Application' from a 'Controller'+returning a 404 (not found) response if all routes fail.++This package also includes the "Web.Frank" module which provide an API to create+applications similar to the Sinatra framework for Ruby, and the "Web.REST"+module to create RESTful applications similar to Ruby on Rails. Neither of+these modules is \"special\", in the sense that they are merely implemented in+terms of 'Controller's. The example above could be rewritten using "Web.Frank"+as such:++@+  controllerApp () $ do+    get \"/\" $ do+      ... display home page ...+    get \"/posts\" $ do+      ... get all posts ...+    post \"/posts\" $ do+      ... create new post ...+@++\Simple\ is broken down into the following modules:++@+  Web+  |-- "Web.Simple" - Re-exports most common modules+  |   |-- "Web.Simple.Controller" - Base monad and built-in routing combinators+  |   |-- "Web.Simple.Responses" - Common HTTP responses+  |   |-- "Web.Simple.Auth" - 'Controller's for authentication+  |   |-- "Web.Simple.Cache" - in memory and filesystem cache utilities+  |-- "Web.Frank" - Sinatra style 'Route's+  +-- "Web.REST" - Monad for creating RESTful controllers+@++-}++{- $Tutorial+#tutorial#++/Simple/ comes with a utility called \smpl\ which automates some common tasks+like creating a new application, running migrations and launching a development+server. To create a new /Simple/ app in a directory called \"example_app\", run:++@+  $ smpl create example_app+@++This will create a directory called \"example_app\" containing a /.cabal/ file+and and a single Haskell source file, \"Main.hs\":++@+\{\-\# LANGUAGE OverloadedStrings #\-\}++module Main where++import Web.Simple+import Network.Wai.Handler.Warp+import System.Posix.Env++app :: (Application -> IO ()) -> IO ()+app runner = runner $ do+  -- TODO: App initialization code here+  controllerApp () $ do+    respond $ okHtml \"Hello World\"++main :: IO ()+main = do+  port <- read \`fmap\` getEnvDefault \"PORT\" \"3000\"+  app (run port)+@++The `app` function is the entry point to your application. The argument is a+function that knows how to run a `Network.Wai.Application` -- for example,+warp's run method. `mkRouter` transforms a `Routeable` into an+`Network.Wai.Application`. The boilerplate is just a `Response` with the body+\"Hello World\" (and content-type \"text/html\"). To run a development server+on port 3000:++@+  $ cd example_app+  $ smpl+@++Pointing your browser to <http://localhost:3000> should display+\"Hello World\"!+-}++{- $Controllers+#controllers#++What is this 'controllerApp' business? The basic type in /Simple/ is a+'Controller' which contains both a 'Request' and app specific state.+'controllerApp' takes an initial application state (/unit/ in the example above)+and transforms a 'Controller' into a WAI 'Application' so it can be run by a+server like warp.++A 'Controller' is a 'Monad' that can perform actions in 'IO' (using 'liftIO'),+access the underlying 'request' or application state (via 'controllerState').+Finally, a 'Controller' can 'respond' to a request. 'respond' short-circuits+the rest of the computation and returns the 'Response' to the client.+'controllerApp' transforms a 'Controller' into a WAI application by running the+'Controller'. If the 'Controller' does not call 'respond', 'controllerApp'+defaults to responding to the client with a 404 not found. For example:++@+controllerApp () $ do+  liftIO $ putStrLn \"Responding to request\"+  respond $ okHtml \"Hello World\"+  liftIO $ putStrLn \"This message is never actually printed\"+@++When run, this code will always print the first message+(\"Responding to request\") and respond with a 200 page containing \"Hello+World\", but never print the second message. Short-circuiting the computation+in this way allows us to respond in different ways based on the request:++@+controllerApp () $ do+  path \<- rawPathInfo \<$> request+  when (path == \"/timeofday\") $ do+    timeStr \<- liftIO $ S8.pack . show \<$> getClockTime+    respond $ okHtml timeStr+  when (path == \"/whoami\") $+    user \<- liftIO $ S8.pack \<$> getLoginName+    respond $ okHtml user+@++This controller will respond with the current time if the path \"/timeofday\"+is requested, and the user running the server if the path \"/whoami\" is+requested. If neither of those paths match, it will respond with a 404+(NOT FOUND).++ -}++{- $Routing+#routing#++An app that does the same thing for every request is not very useful (well, it+might be, but if it is, even /Simple/ is not simple enough for you). We want to+build applications that do perform different actions based on properties of the+client\'s request - e.g., the path requests, GET or POST requests, the \"Host\"+header, etc\'. /Simple/\'s 'Controller's are flexible to accomplish this.+'Controller's encapsulate a function from a 'Request' to 'Either' a 'Response'+or some monadic value.++For example, let\'s extend the example using the 'Monad' syntax:++@+controllerApp () $ do+  routeTop $ do+    routeHost \"localhost\" $ respond $ okHtml \"Hello, localhost!\"+    routeHost \"test.lvh.me\" $ respond $ okHtml \"Hello, test.lvh.me!\"+  routeName \"advice\" $ okHtml \"Be excellent to each other!\"+@++Now, the app will respond differently depending on whether the client is+requesting the host name \"localhost\" or \"test.lvh.me\", or if the requested+path is \"\/advice\" rather than \"\/\". Take it for a spin in the browser (make+sure `smpl` is still running):++  * <http://localhost:3000>++  * <http://test.lvh.me:3000>++  * <http://localhost:3000/advice>++In this example, 'routeTop' matches if the 'Network.Wai.Request's+'Network.Wai.pathInfo' is empty, which means the requested path is \"\/\" (as+in this case), or the rest of the path has been consumed by previous 'Route's.+'routeName' matches if the next component in the path (specifically the 'head'+of 'Network.Wai.pathInfo') matches the argument (and if so, removes it). Check+out "Web.Simple.Router" for more complete documentation of these and other+'Route's.++For many apps it will be convenient to use even higher level routing APIs. The+modules "Web.Frank" and "Web.Sinatra" provide Sinatra-like and RESTful APIs,+respectively. Both modules are implement purely in terms of 'Route's and you+can easily implement your own patterns as well.++-} 

@@ -1,63 +1,70 @@-{-# LANGUAGE OverloadedStrings, Rank2Types #-}-module Web.Simple.Auth where+{-# LANGUAGE OverloadedStrings #-} -import Control.Monad.IO.Class (liftIO)+-- | Provides HTTP Basic Authentication.+module Web.Simple.Auth+  ( AuthRouter+  , basicAuthRoute, basicAuth, authRewriteReq+  ) where++import Control.Monad import Data.ByteString.Base64 import qualified Data.ByteString.Char8 as S8+import Data.Maybe import Network.HTTP.Types import Network.Wai import Web.Simple.Responses-import Web.Simple.Router+import Web.Simple.Controller  -- | An 'AuthRouter' authenticates a 'Request' and, if successful, forwards the -- 'Request' to the 'Routeable'.-type AuthRouter r = Routeable r-                  => (Request -> S8.ByteString-                              -> S8.ByteString-                              -> IO (Maybe Request))-                  -> r-                  -> Route ()+type AuthRouter r a = (Request -> S8.ByteString+                               -> S8.ByteString+                               -> Controller r (Maybe Request))+                  -> Controller r a+                  -> Controller r a  -- | An 'AuthRouter' that uses HTTP basic authentication to authenticate a request -- in a particular realm.-basicAuthRoute :: String -> AuthRouter r-basicAuthRoute realm testAuth rt = Route (\req -> do-  didAuthenticate <--    case lookup hAuthorization (requestHeaders req) of-      Nothing -> return Nothing-      Just authStr-              | S8.take 5 authStr /= "Basic" -> return Nothing-              | otherwise -> do-                    let up = fmap (S8.split ':') $ decode $ S8.drop 6 authStr-                    case up of-                      Right (user:pass:[]) -> liftIO $ testAuth req user pass-                      _ -> return Nothing-  case didAuthenticate of-    Nothing -> return $ Just $ requireBasicAuth realm-    Just finReq -> runRoute rt finReq-  ) ()+basicAuthRoute :: String -> AuthRouter r a+basicAuthRoute realm testAuth next = do+  req <- request+  let authStr = fromMaybe "" $ lookup hAuthorization (requestHeaders req)+  when (S8.take 5 authStr /= "Basic") requireAuth +  case fmap (S8.split ':') $ decode $ S8.drop 6 authStr of+    Right (user:pwd:[]) -> do+      mfin <- testAuth req user pwd+      maybe requireAuth (\finReq -> localRequest (const finReq) next) mfin+    _ -> requireAuth+  where requireAuth = respond $ requireBasicAuth realm+ -- | Wraps an 'AuthRouter' to take a simpler authentication function (that just -- just takes a username and password, and returns 'True' or 'False'). It also -- adds an \"X-User\" header to the 'Request' with the authenticated user\'s -- name (the first argument to the authentication function).-authRewriteReq :: Routeable r-                    => AuthRouter r-                    -> (S8.ByteString -> S8.ByteString -> IO Bool)-                    -> r-                    -> Route ()+authRewriteReq :: AuthRouter r a+                    -> (S8.ByteString -> S8.ByteString -> Controller r Bool)+                    -> Controller r a+                    -> Controller r a authRewriteReq authRouter testAuth rt =   authRouter (\req user pwd -> do     success <- testAuth user pwd     if success then       return $ Just $ transReq req user       else return Nothing) rt-  where transReq req user = req { requestHeaders = ("X-User", user):(requestHeaders req)}+  where transReq req user = req+          { requestHeaders = ("X-User", user):(requestHeaders req)}  -- | A 'Route' that uses HTTP basic authentication to authenticate a request for a realm -- with the given username ans password. The request is rewritten with an 'X-User' header--- containing the authenticated username before being passed to the next next 'Route'.-basicAuth :: Routeable r => String -> S8.ByteString -> S8.ByteString -> r -> Route ()-basicAuth realm user pass = authRewriteReq (basicAuthRoute realm)-  (\u p -> return $ u == user && p == pass)+-- containing the authenticated username before being passed to the next 'Route'.+basicAuth :: String+          -- ^ Realm+          -> S8.ByteString+          -- ^ Username+          -> S8.ByteString+          -- ^ Password+          -> Controller r a -> Controller r a+basicAuth realm user pwd = authRewriteReq (basicAuthRoute realm)+  (\u p -> return $ u == user && p == pwd) 

@@ -0,0 +1,86 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}++-- | Provides a general caching interface along with a simple in-memory+-- (process only) and file based cache implementations.+module Web.Simple.Cache +  ( -- * Cache Interface+    Cache(..), fetchOr+    -- * Cache Implementations+  , FileSystemCache, newFileSystemCache+  , InMemCache, newInMemCache+  ) where++import Control.Monad+import Control.Monad.IO.Class+import qualified Data.ByteString.Lazy.Char8 as L8+import qualified Data.HashTable.IO as H+import System.FilePath+import System.Directory++-- | A class that captures a simple key-value caching interface. The keys are+-- simply 'String'\'s and values are simply 'ByteString'\'s.+class Cache c where+  put        :: MonadIO m => c -> String -> L8.ByteString -> m L8.ByteString+  -- ^ Store a value in the cache. The returned value should be the value that+  -- was just stored.+  fetch      :: MonadIO m => c -> String -> m (Maybe L8.ByteString)+  -- ^ Retrieve a value from the cache.+  invalidate :: MonadIO m => c -> String -> m ()+  -- ^ Invalidate a potentially existing value in the cache. Depending on the+  -- implementation this may or may not free the space used by the key-value+  -- pair.++fetchOr :: (Cache c, MonadIO m)+        => c+        -> String+        -> m L8.ByteString+        -> m L8.ByteString+fetchOr c path act = do+  mcached <- fetch c path+  maybe (act >>= put c path) return mcached++-- | A file based cache implementation. Files are stored in subdirectories of+-- @fsCacheBase@.+newtype FileSystemCache = FileSystemCache { fsCacheBase :: FilePath }++-- | Create a new @FileSystemCache@.+newFileSystemCache :: FilePath -> FileSystemCache+newFileSystemCache = FileSystemCache++instance Cache FileSystemCache where+  put c path d = liftIO $ do+    let components =  splitDirectories $ dropDrive path+    let fullPath = (fsCacheBase c):components+    createDirectoryIfMissing True $+      joinPath $ reverse $ tail $ reverse fullPath+    L8.writeFile (joinPath fullPath) d+    return d++  fetch c path = liftIO $ do+    let components =  splitDirectories $ dropDrive path+    let fullPath = joinPath $ (fsCacheBase c):components+    exists <- doesFileExist fullPath+    if exists then+      fmap Just $ L8.readFile fullPath+      else return Nothing++  invalidate c path = liftIO $ do+    let components =  splitDirectories $ dropDrive path+    let fullPath = joinPath $ (fsCacheBase c):components+    exists <- doesFileExist fullPath+    when exists $+      removeFile fullPath++-- | An in-memory cache implementation. The current processes heap space is+-- simply used as the cache.+newtype InMemCache = InMemCache (H.BasicHashTable String L8.ByteString)++-- | Create a new @InMemCache@.+newInMemCache :: MonadIO m => m InMemCache+newInMemCache = liftIO $ fmap InMemCache H.new++instance Cache InMemCache where+  put (InMemCache h) path d = liftIO $ H.insert h path d >> return d+  fetch (InMemCache h) = liftIO . (H.lookup h)+  invalidate (InMemCache h) = liftIO . (H.delete h)+

@@ -1,8 +1,11 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}  {- | 'Controller' provides a convenient syntax for writting 'Application'-  code as a Monadic action with access to an HTTP request, rather than a-  function that takes the request as an argument. This module also defines some+  code as a Monadic action with access to an HTTP request as well as app+  specific data (e.g. a database connection pool, app configuration etc.)+  This module also defines some   helper functions that leverage this feature. For example, 'redirectBack'   reads the underlying request to extract the referer and returns a redirect   response:@@ -16,85 +19,258 @@           ...   @ -}- module Web.Simple.Controller-  ( Controller-  -- * Utility functions+  (+  -- * Example+  -- $Example+  -- * Controller Monad+    Controller(..), runController, runControllerIO+  , controllerApp, controllerState, localState+  , request, localRequest, respond+  -- * Common Routes+  , routeHost, routeTop, routeMethod, routeAccept+  , routePattern, routeName, routeVar+  -- * Inspecting query+  , Parseable+  , queryParam, queryParam', queryParams+  , readQueryParam, readQueryParam', readQueryParams+  , parseForm+  -- * Redirection via referrer   , redirectBack   , redirectBackOr-  , queryParam-  , parseForm-  , respond-  -- * Low level functions-  , request+  -- * Exception handling+  , ControllerException+  , module Control.Exception.Peel+  -- * Integrating other WAI components+  , ToApplication(..)+  , fromApp+  -- * Low-level utilities   , body+  -- , guard, guardM, guardReq   ) where -import Control.Monad.Trans.Class-import Control.Monad.Trans.Reader+import           Control.Applicative+import           Control.Exception.Peel+import           Control.Monad hiding (guard)+import           Control.Monad.IO.Class+import           Control.Monad.IO.Peel import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy.Char8 as L8-import Data.Conduit-import Data.Conduit.List as CL-import Network.HTTP.Types.Header-import Network.Wai-import Network.Wai.Parse-import Web.Simple.Responses-import Web.Simple.Router+import           Data.Conduit+import qualified Data.Conduit.List as CL+import           Data.List (find)+import           Data.Maybe+import           Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import           Data.Typeable+import           Network.HTTP.Types+import           Network.Wai+import           Network.Wai.Parse+import           Web.Simple.Responses -data ControllerState = ControllerState { csRequest :: Request }+-- | The Controller Monad is both a Reader-like monad which, when run, computes+-- either a 'Response' or a result. Within the Controller Monad, the remainder+-- of the computation can be short-circuited by 'respond'ing with a 'Response'.+newtype Controller r a =+  Controller ((r,Request) -> ResourceT IO (Either Response a)) --- | A 'Controller' is a 'Reader' monad that contains the HTTP request in its--- environment. A 'Controller' is 'Routeable' simply by running the 'Reader'.-type Controller = ReaderT ControllerState (ResourceT IO)+instance Functor (Controller r) where+  fmap f (Controller act) = Controller $ \st -> do+    eaf <- act st+    case eaf of+      Left resp -> return $ Left resp+      Right result -> return $ Right $ f result -instance Routeable (Controller Response) where-  runRoute controller req = fmap Just $-    runReaderT controller $ ControllerState req+instance Applicative (Controller r) where+  pure a = Controller $ \_ -> return $ Right a+  (Controller fn) <*> (Controller act) =+    Controller $ \st -> do+      eact <- act st+      case eact of+        Left resp -> return $ Left resp+        Right result -> do+          ef <- fn st+          either (return . Left) (\f -> return . Right $ f result) ef --- | Reads the underlying 'Request'-request :: Controller Request-request = fmap csRequest ask+instance Monad (Controller r) where+  return = pure+  (Controller act) >>= fn = Controller $ \st -> do+    eres <- act st+    case eres of+      Left resp -> return $ Left resp+      Right result -> do+        let (Controller fres) = fn result+        fres st --- | Redirect back to the referer. If the referer header is not present--- redirect to root (i.e., @\/@).-redirectBack :: Controller Response-redirectBack = redirectBackOr (redirectTo "/")+instance MonadIO (Controller r) where+  liftIO act = Controller $ \_ -> fmap Right $ liftIO act --- | Redirect back to the referer. If the referer header is not present--- fallback on the given 'Response'.-redirectBackOr :: Response -- ^ Fallback 'Response'-               -> Controller Response-redirectBackOr def = do-  mrefr <- requestHeader "referer"-  case mrefr of-    Just refr -> return $ redirectTo $ S8.unpack refr-    Nothing   -> return def+hoistEither :: Either Response a -> Controller r a+hoistEither eith = Controller $ \_ -> return eith --- | Looks up the parameter name in the request's query string and returns the--- value as a 'S8.ByteString' or 'Nothing'.+instance MonadPeelIO (Controller r) where+  peelIO = do+    r <- controllerState+    req <- request+    return $ \ctrl -> do+      res <- runControllerIO ctrl r req+      return $ hoistEither res++ask :: Controller r (r, Request)+ask = Controller $ \rd -> return (Right rd)++-- | Extract the request+request :: Controller r Request+request = liftM snd ask++local :: ((r, Request) -> (r, Request)) -> Controller r a -> Controller r a+local f (Controller act) = Controller $ \st -> act (f st)++-- | Modify the request for the given computation+localRequest :: (Request -> Request) -> Controller r a -> Controller r a+localRequest f = local (\(r,req) -> (r, f req))++-- | Extract the application-specific state+controllerState :: Controller r r +controllerState = liftM fst ask++-- | Modify the application state for the given computation+localState :: (r -> r) -> Controller r a -> Controller r a+localState f = local (\(r,req) -> (f r, req))++-- | Convert the controller into an 'Application'+controllerApp :: r -> Controller r a -> Application+controllerApp r ctrl req =+  runController ctrl r req >>=+    either return (const $ return notFound) ++runController :: Controller r a -> r -> Request -> ResourceT IO (Either Response a)+runController (Controller fun) r req = fun (r,req)++-- | Run a 'Controller' in the @IO@ monad+runControllerIO :: Controller r a -> r -> Request -> IO (Either Response a)+runControllerIO ctrl r = runResourceT . runController ctrl r++-- | Decline to handle the request ----- For example, for a request with query string: \"?foo=bar&baz=7\",--- @---   queryParam \"foo\"--- @+-- @pass >> c === c@+-- @c >> pass === c@+pass :: Controller r ()+pass = Controller $ \_ -> return (Right ())++-- | Provide a response ----- would return /Just "bar"/, but+-- @respond r >>= f === respond r@+respond :: Response -> Controller r a+respond resp = Controller $ \_ -> return $ Left resp+++-- | Lift an application to a controller+fromApp :: ToApplication a => a -> Controller r ()+fromApp app = Controller (\(_, req) -> Left `fmap` ((toApp app) req))++-- | Matches on the hostname from the 'Request'. The route only succeeds on+-- exact matches.+routeHost :: S.ByteString -> Controller r a -> Controller r ()+routeHost host = guardReq $ (host ==) . serverName++-- | Matches if the path is empty. ----- @---   queryParam \"zap\"--- @+-- Note that this route checks that 'pathInfo'+-- is empty, so it works as expected in nested contexts that have+-- popped components from the 'pathInfo' list.+routeTop :: Controller r a -> Controller r ()+routeTop = guardReq $ \req -> null (pathInfo req) ||+                              (T.length . head $ pathInfo req) == 0++-- | Matches on the HTTP request method (e.g. 'GET', 'POST', 'PUT')+routeMethod :: StdMethod -> Controller r a -> Controller r ()+routeMethod method = guardReq $ (renderStdMethod method ==) . requestMethod++-- | Matches if the request's Content-Type exactly matches the given string+routeAccept :: S8.ByteString -> Controller r a -> Controller r ()+routeAccept contentType = guardReq (isJust . find matching . requestHeaders)+ where matching hdr = fst hdr == hAccept && snd hdr == contentType++-- | Routes the given URL pattern. Patterns can include+-- directories as well as variable patterns (prefixed with @:@) to be added+-- to 'queryString' (see 'routeVar') ----- would return /Nothing/-queryParam :: Parseable a => S8.ByteString -- ^ Parameter name-           -> Controller (Maybe a)+--  * \/posts\/:id+--+--  * \/posts\/:id\/new+--+--  * \/:date\/posts\/:category\/new+--+routePattern :: S.ByteString -> Controller r a -> Controller r ()+routePattern pattern route =+  let patternParts = map T.unpack $ decodePathSegments pattern+  in foldr mkRoute (route >> return ()) patternParts+  where mkRoute (':':varName) = routeVar (S8.pack varName)+        mkRoute name = routeName (S8.pack name)++-- | Matches if the first directory in the path matches the given 'ByteString'+routeName :: S.ByteString -> Controller r a -> Controller r ()+routeName name next = do+  req <- request+  if (length $ pathInfo req) > 0 && S8.unpack name == (T.unpack . head . pathInfo) req+    then localRequest popHdr next >> return ()+    else pass+  where popHdr req = req { pathInfo = (tail . pathInfo $ req) }++-- | Always matches if there is at least one directory in 'pathInfo' but and+-- adds a parameter to 'queryString' where the key is the first parameter and+-- the value is the directory consumed from the path.+routeVar :: S.ByteString -> Controller r a -> Controller r ()+routeVar varName next = do+  req <- request+  case pathInfo req of+    [] -> pass+    x:_ | T.null x -> pass+        | otherwise -> localRequest popHdr next >> return ()+  where popHdr req = req {+              pathInfo = (tail . pathInfo $ req)+            , queryString = (varName, Just (varVal req)):(queryString req)}+        varVal req = S8.pack . T.unpack . head . pathInfo $ req++--+-- query parameters+--++-- | Looks up the parameter name in the request's query string and returns the+-- @Parseable@ value or 'Nothing'.+--+-- For example, for a request with query string: \"?foo=bar&baz=7\",+-- @queryParam \"foo\"@+-- would return @Just "bar"@, but+-- @queryParam \"zap\"@+-- would return @Nothing@.+queryParam :: Parseable a+           => S8.ByteString -- ^ Parameter name+           -> Controller r (Maybe a) queryParam varName = do-  qr <- fmap queryString request-  case lookup varName qr of-    Just p -> return $ fmap parse p-    _ -> return Nothing+  qr <- liftM queryString request+  return $ case lookup varName qr of+    Just p -> Just $ parse $ fromMaybe S.empty p+    _ -> Nothing +-- | Like 'queryParam', but throws an exception if the parameter is not present.+queryParam' :: Parseable a+            => S.ByteString -> Controller r a+queryParam' varName =+  queryParam varName >>= maybe (err $ "no parameter " ++ show varName) return++-- | Selects all values with the given parameter name+queryParams :: Parseable a+            => S.ByteString -> Controller r [a]+queryParams varName = request >>= return .+                                  map (parse . fromMaybe S.empty . snd) .+                                  filter ((== varName) . fst) .+                                  queryString++-- | The class of types into which query parameters may be converted class Parseable a where   parse :: S8.ByteString -> a @@ -102,45 +278,39 @@   parse = id instance Parseable String where   parse = S8.unpack-instance Parseable Integer where-  parse = parseReadable+instance Parseable Text where+  parse = T.decodeUtf8 -parseReadable :: Read a => S8.ByteString -> a-parseReadable = read . S8.unpack+-- | Like 'queryParam', but further processes the parameter value with @read@.+-- If that conversion fails, an exception is thrown.+readQueryParam :: Read a+               => S8.ByteString -- ^ Parameter name+               -> Controller r (Maybe a)+readQueryParam varName =+  queryParam varName >>= maybe (return Nothing) (liftM Just . readParamValue varName) --- | An alias for 'return' that's helps the the compiler type a code block as a--- 'Controller'. For example, when using the 'Network.Wai.Frank' routing DSL to--- define a simple route that justs returns a 'Response', 'respond' can be used--- to avoid explicit typing of the argument:------ @---   get \"/\" $ do---     someSideEffect---     respond $ okHtml \"Hello World\"--- @------ instead of:------ @---   get \"/\" $ (do---     someSideEffect---     return $ okHtml \"Hello World\") :: Controller Response--- @-respond :: Routeable r => r -> Controller r-respond = return+-- | Like 'readQueryParam', but throws an exception if the parameter is not present.+readQueryParam' :: Read a+                => S8.ByteString -- ^ Parameter name+                -> Controller r a+readQueryParam' varName =+  queryParam' varName >>= readParamValue varName --- | Returns the value of the given request header or 'Nothing' if it is not--- present in the HTTP request.-requestHeader :: HeaderName -> Controller (Maybe S8.ByteString)-requestHeader name = do-  req <- request-  return $ lookup name $ requestHeaders req+-- | Like 'queryParams', but further processes the parameter values with @read@.+-- If any read-conversion fails, an exception is thrown.+readQueryParams ::  Read a+                => S8.ByteString -- ^ Parameter name+                -> Controller r [a]+readQueryParams varName =+  queryParams varName >>= mapM (readParamValue varName) --- | Reads and returns the body of the HTTP request.-body :: Controller L8.ByteString-body = do-  bd <- fmap requestBody request-  lift $ bd $$ (CL.consume >>= return . L8.fromChunks)+readParamValue :: Read a => S8.ByteString -> Text -> Controller r a+readParamValue varName =+  maybe (err $ "cannot read parameter: " ++ show varName) return .+    readMay . T.unpack+  where readMay s = case [x | (x,rst) <- reads s, ("", "") <- lex rst] of+                      [x] -> Just x+                      _ -> Nothing  -- | Parses a HTML form from the request body. It returns a list of 'Param's as -- well as a list of 'File's, which are pairs mapping the name of a /file/ form@@ -158,7 +328,101 @@ --         respond $ redirectTo \"/\" --       Nothing -> redirectBack -- @-parseForm :: Controller ([Param], [(S.ByteString, FileInfo FilePath)])-parseForm = do-  request >>= lift . (parseRequestBody tempFileBackEnd)+parseForm :: Controller r ([Param], [(S.ByteString, FileInfo FilePath)])+parseForm = Controller $ \(_, req) -> do+  Right `fmap` parseRequestBody tempFileBackEnd req +-- | Reads and returns the body of the HTTP request.+body :: Controller r L8.ByteString+body = Controller $ \(_, req) -> do+  Right `fmap` (requestBody req $$ CL.consume >>= return . L8.fromChunks)++-- | Returns the value of the given request header or 'Nothing' if it is not+-- present in the HTTP request.+requestHeader :: HeaderName -> Controller r (Maybe S8.ByteString)+requestHeader name = request >>= return . lookup name . requestHeaders++-- | Redirect back to the referer. If the referer header is not present+-- redirect to root (i.e., @\/@).+redirectBack :: Controller r ()+redirectBack = redirectBackOr (redirectTo "/")++-- | Redirect back to the referer. If the referer header is not present+-- fallback on the given 'Response'.+redirectBackOr :: Response -- ^ Fallback response+               -> Controller r ()+redirectBackOr def = do+  mrefr <- requestHeader "referer"+  case mrefr of+    Just refr -> respond $ redirectTo $ S8.unpack refr+    Nothing   -> respond def++-- guard++guard :: Bool -> Controller r a -> Controller r ()+guard b c = if b then c >> return () else pass++guardM :: Controller r Bool -> Controller r a -> Controller r ()+guardM b c = b >>= flip guard c++guardReq :: (Request -> Bool) -> Controller r a -> Controller r ()+guardReq f = guardM (liftM f request)++-- | The class of types that can be converted to an 'Application'+class ToApplication r where+  toApp :: r -> Application++instance ToApplication Application where+  toApp = id++instance ToApplication Response where+  toApp = const . return++data ControllerException = ControllerException String+  deriving (Typeable)++instance Show ControllerException where+  show (ControllerException msg) = "Controller: " ++ msg++instance Exception ControllerException++err :: String -> Controller r a+err = throwIO . ControllerException++{- $Example+ #example#++The most basic 'Routeable' types are 'Application' and 'Response'. Reaching+either of these types marks a termination in the routing lookup. This module+exposes a monadic type 'Route' which makes it easy to create routing logic+in a DSL-like fashion.++'Route's are concatenated using the '>>' operator (or using do-notation).+In the end, any 'Routeable', including a 'Route' is converted to an+'Application' and passed to the server using 'mkRoute':++@++  mainAction :: Controller () ()+  mainAction = ...++  signinForm :: Controller () ()+  signinForm req = ...++  login :: Controller () ()+  login = ...++  updateProfile :: Controller () ()+  updateProfile = ...++  main :: IO ()+  main = run 3000 $ controllerApp () $ do+    routeTop mainAction+    routeName \"sessions\" $ do+      routeMethod GET signinForm+      routeMethod POST login+    routeMethod PUT $ routePattern \"users/:id\" updateProfile+    routeAll $ responseLBS status404 [] \"Are you in the right place?\"+@++-}

@@ -1,27 +0,0 @@-module Web.Simple.Migrations-  ( Migration-  , newMigration-  ) where--import System.Locale-import System.Time--type Migration =  String -- ^ Version-               -> String -- ^ Migration name-               -> IO Bool--newMigration :: String -> IO ()-newMigration name = do-  time <- getClockTime >>= return . toUTCTime-  let timestr = formatCalendarTime defaultTimeLocale-                  "%Y%m%d%H%M%S" time-  writeFile ("migrate/" ++ timestr ++ "_" ++ name ++ ".hs") migrationTemplate--migrationTemplate :: String-migrationTemplate = concat-  [ "import Web.Simple.Migrations\n\n"-  , "up :: Migration\n"-  , "up = const . const $ return False\n\n"-  , "down :: Migration\n"-  , "down = const . const $ return False\n\n"]-

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+ -- | This module defines some convenience functions for creating responses. module Web.Simple.Responses   ( ok, okHtml, okJson@@ -123,8 +124,8 @@                        \</BODY></HTML>\n"]  -- | Returns a 500 (Server Error) 'Response'.-serverError :: Response-serverError= mkHtmlResponse status500 [] html+serverError :: L8.ByteString -> Response+serverError message = mkHtmlResponse status500 [] html   where html = L8.concat              [L8.pack               "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\@@ -132,5 +133,6 @@               \<TITLE>500 Internal Server Error</TITLE>\n\               \</HEAD><BODY>\n\               \<H1>Internal Server Error</H1>\n\-              \</BODY></HTML>\n"]+              \<P>", message,+              "</P></BODY></HTML>\n"] 

@@ -1,239 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{- |--Conceptually, a route is function that, given an HTTP request, may return-an action (something that would return a response for the client if run).-Routes can be concatenated--where each route is evaluated until one-matches--and nested. Routes are expressed through the 'Routeable' type class.-'runRoute' transforms an instance of 'Routeable' to a function from 'Request'-to a monadic action (in the 'ResourceT' monad) that returns a-'Maybe' 'Response'. The return type was chosen to be monadic so routing-decisions can depend on side-effects (e.g. a random number or counter for A/B-testing, IP geolocation lookup etc').---}--module Web.Simple.Router-  (-  -- * Example-  -- $Example-    Routeable(..)-  , mkRouter-  -- * Route Monad-  , Route(..)-  -- * Common Routes-  , routeAll, routeHost, routeTop, routeMethod-  , routePattern, routeName, routeVar-  ) where--import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as S8-import Data.Monoid-import Data.Conduit-import qualified Data.Text as T-import Network.HTTP.Types-import Network.Wai-import Web.Simple.Responses--{- |-'Routeable' types can be converted into a route function using 'runRoute'.-If the route is matched it returns a 'Response', otherwise 'Nothing'.--In general, 'Routeable's are data-dependant (on the 'Request'), but don't have-to be. For example, 'Application' is an instance of 'Routeable' that always-returns a 'Response':--@-  instance Routeable Application where-    runRoute app req = app req >>= return . Just-@---}-class Routeable r where-  runRoute :: r -> Request -> ResourceT IO (Maybe Response)---- | Converts any 'Routeable' into an 'Application' that can be passed directly--- to a WAI server.-mkRouter :: Routeable r => r -> Application-mkRouter route req = do-  mapp <- runRoute route req-  case mapp of-    Just resp -> return resp-    Nothing -> return notFound---instance Routeable Application where-  runRoute app req = fmap Just $ app req--instance Routeable Response where-  runRoute resp = const . return . Just $ resp--{- |-The 'Route' type is a basic instance of 'Routeable' that simply holds the-routing function and an arbitrary additional data parameter. The power is-derived from the instances of 'Monad' and 'Monoid', which allow the-simple construction of complex routing rules using either lists ('Monoid') or-do-notation. Moreover, because of it's simple type, any 'Routeable' can be used-as a 'Route' (using 'routeAll' or by applying it to 'runRoute'), making it-possible to leverage the monadic or monoid syntax for any 'Routeable'.--Commonly, route functions that construct a 'Route' only inspect the 'Request'-and other parameters. For example, 'routeHost' looks at the hostname:--@-  routeHost :: Routeable r => S.ByteString -> r -> Route ()-  routeHost host route = Route func ()-    where func req = if host == serverName req-                       then runRoute route req-                       else return Nothing-@--However, because the result of a route is in the-'ResourceT' monad, routes have all the power of an 'Application' and can make-state-dependant decisions. For example, it is trivial to implement a route that-succeeds for every other request (perhaps for A/B testing):--@-  routeEveryOther :: (Routeable r1, Routeable r2)-                  => TVar Int -> r1 -> r2 -> Route ()-  routeEveryOther counter r1 r2 = Route func ()-    where func req = do-            i <- liftIO . atomically $ do-                    i' <- readTVar counter-                    writeTVar counter (i' + 1)-                    return i'-            if i `mod` 2 == 0-              then runRoute r1 req-              else runRoute r2 req-@---}-data Route a = Route (Request -> ResourceT IO (Maybe Response)) a--mroute :: (Request -> ResourceT IO (Maybe Response)) -> Route ()-mroute handler = Route handler ()--instance Monad Route where-  return a = Route (const $ return Nothing) a-  (Route rtA valA) >>= fn =-    let (Route rtB valB) = fn valA-    in Route (\req -> do-      resA <- rtA req-      case resA of-        Nothing -> rtB req-        Just _ -> return resA) valB--instance Monoid (Route ()) where-  mempty = mroute $ const $ return Nothing-  mappend (Route a _) (Route b _) = mroute $ \req -> do-    c <- a req-    case c of-      Nothing -> b req-      Just _ -> return c--instance Routeable (Route a) where-  runRoute (Route rtr _) req = rtr req---- | A route that always matches (useful for converting a 'Routeable' into a--- 'Route').-routeAll :: Routeable r => r -> Route ()-routeAll = mroute . runRoute---- | Matches on the hostname from the 'Request'. The route only successeds on--- exact matches.-routeHost :: Routeable r => S.ByteString -> r -> Route ()-routeHost host route = mroute $ \req ->-  if host == serverName req then runRoute route req-  else return Nothing---- | Matches if the path is empty. Note that this route checks that 'pathInfo'--- is empty, so it works as expected when nested under namespaces or other--- routes that pop the 'pathInfo' list.-routeTop :: Routeable r => r -> Route ()-routeTop route = mroute $ \req ->-  if null (pathInfo req)  || (T.length . head $ pathInfo req) == 0-    then runRoute route req-    else return Nothing---- | Matches on the HTTP request method (e.g. 'GET', 'POST', 'PUT')-routeMethod :: Routeable r => StdMethod -> r -> Route ()-routeMethod method route = mroute $ \req ->-  if renderStdMethod method == requestMethod req then-    runRoute route req-    else return Nothing---- | Routes the given URL pattern. Patterns can include--- directories as well as variable patterns (prefixed with @:@) to be added--- to 'queryString' (see 'routeVar')------  * \/posts\/:id------  * \/posts\/:id\/new------  * \/:date\/posts\/:category\/new----routePattern :: Routeable r => S.ByteString -> r -> Route ()-routePattern pattern route =-  let patternParts = map T.unpack $ decodePathSegments pattern-  in foldr mkRoute (mroute . runRoute $ routeTop route) patternParts-  where mkRoute (':':varName) = routeVar (S8.pack varName)-        mkRoute varName = routeName (S8.pack varName)---- | Matches if the first directory in the path matches the given 'ByteString'-routeName :: Routeable r => S.ByteString -> r -> Route ()-routeName name route = mroute $ \req ->-  let poppedHdrReq = req { pathInfo = (tail . pathInfo $ req) }-  in if (length $ pathInfo req) > 0 && S8.unpack name == (T.unpack . head . pathInfo) req-    then runRoute route poppedHdrReq-    else return Nothing---- | Always matches if there is at least one directory in 'pathInfo' but and--- adds a parameter to 'queryString' where the key is the first parameter and--- the value is the directory consumed from the path.-routeVar :: Routeable r => S.ByteString -> r -> Route ()-routeVar varName route = mroute $ \req ->-  let varVal = S8.pack . T.unpack . head . pathInfo $ req-      poppedHdrReq = req {-          pathInfo = (tail . pathInfo $ req)-        , queryString = (varName, Just varVal):(queryString req)}-  in if (length $ pathInfo req) > 0 then runRoute route poppedHdrReq-  else return Nothing--{- $Example- #example#--The most basic 'Routeable' types are 'Application' and 'Response'. Reaching-either of these types marks a termination in the routing lookup. This module-exposes a monadic type 'Route' which makes it easy to create routing logic-in a DSL-like fashion.--'Route's are concatenated using the '>>' operator (or using do-notation).-In the end, any 'Routeable', including a 'Route' is converted to an-'Application' and passed to the server using 'mkRouter':--@--  mainAction :: Application-  mainAction req = ...--  signinForm :: Application-  signinForm req = ...--  login :: Application-  login req = ...--  updateProfile :: Application-  updateProfile req = ...--  main :: IO ()-  main = runSettings defaultSettings $ mkRouter $ do-    routeTop mainAction-    routeName \"sessions\" $ do-      routeMethod GET signinForm-      routeMethod POST login-    routeMethod PUT $ routePattern \"users/:id\" updateProfile-    routeAll $ responseLBS status404 [] \"Are you in the right place?\"-@---}-

@@ -2,105 +2,80 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                simple-version:             0.4.1+version:             0.5.0 synopsis: A minimalist web framework for the WAI server interface description:    \Simple\ is \"framework-less\" web framework for Haskell web applications-  using the WAI server interface (e.g. for use with the warp server). Unlike-  other frameoworks, \Simple\ does not enforce a particular structure or-  paradigm for web applications. Rather, \Simple\ makes it easier for you, the-  developer, to use whichever paradigm or structure you like. This package-  includes:-  .-  * Web application building blocks under Web.Simple-  .-  * A Sintra (http://www.sinatrarb.com) inspired DSL - Web.Frank-  .-  * A Monad for building RESTful controllers - Web.REST+  based on the WAI server interface (e.g. for use with the warp server).+  \Simple\ does not enforce a particular structure or paradigm for web+  applications. Rather, \Simple\ contains tools to help you create your own+  patterns (or re-create existing ones). \Simple\ is minimalist, providing a+  lightweight base - the most basic \Simple\ app is little more than a WAI+  `Application` with some routing logic. Everything else (e.g. authentication,+  controllers, persistence, caching etc\') is provided in composable units, so+  you can include only the ones you need in your app, and easily replace+  with your own components.   .-  To get started using the warp web server:+  To get started, create an app skeleton with the `smpl` utility:   .   @-    $ cabal install simple warp+    $ cabal install simple+    $ smpl create my_app_name+    $ cd my_app_name+    $ smpl   @   .-  \helloworld.hs\:-  .-  > import Web.Simple-  > import Network.Wai.Handler.Warp-  >-  > main :: IO ()-  > main = runSettings defaultSettings $ mkRouter $-  >         okHtml "Hello World"-  .-  @$ runghc -XOverloadedStrings helloworld.hs@-  .-  See /Web.Simple/ for a more detailed introduction.+  See "Web.Simple" for a more detailed introduction. license:             GPL-3 license-file:        LICENSE-author:              Amit Levy+author:              Amit Levy, Daniel B. Giffin maintainer:          amit@amitlevy.com category:            Web build-type:          Simple cabal-version:       >=1.9.2 +data-files: template/*.tmpl+ executable smpl   Main-Is: smpl.hs+  ghc-options: -Wall   build-depends:-    attoparsec >= 0.10.3,-    base >= 4.5 && < 5.0,-    base64-bytestring >= 1.0 && < 1.1,-    cmdargs >= 0.10.2,-    conduit >= 0.5,-    hint >= 0.3.3 && < 0.4,-    system-filepath >= 0.4.7 && < 0.5,-    system-fileio >= 0.3.11 && < 0.4,-    old-locale,-    old-time,-    wai >= 1.3 && < 2.0,-    wai-extra >= 1.3 && < 2.0,-    wai-handler-devel >= 1.3,-    http-types >= 0.7.1,-    text >= 0.11,-    transformers >= 0.3,-    bytestring >= 0.9,-    postgresql-simple >= 0.2.4.1,-    network >= 2.4,-    mtl >= 2.1+      base < 6+    , attoparsec+    , base64-bytestring+    , bytestring+    , cmdargs+    , conduit+    , directory+    , filepath+    , process+    , stringsearch  library   build-depends:-    base >=4.5 && < 5.0,-    base64-bytestring >= 1.0 && < 1.1,-    conduit >= 0.5,-    old-locale,-    old-time,-    wai >= 1.3 && < 2.0,-    wai-extra >= 1.3 && < 2.0,-    http-types >= 0.7.1,-    text >= 0.11,-    transformers >= 0.3,-    bytestring >= 0.9,-    postgresql-simple >= 0.2.4.1,-    resource-pool >= 0.2.1 && < 0.3,-    resourcet >= 0.4.4,-    network >= 2.4,-    mtl >= 2.1+      base < 6+    , base64-bytestring+    , conduit+    , directory+    , filepath+    , hashtables+    , wai+    , wai-extra+    , http-types+    , text+    , transformers+    , bytestring+    , monad-peel    ghc-options: -Wall -fno-warn-unused-do-bind    exposed-modules:-    Database.PostgreSQL.Models,-    Database.PostgreSQL.Connection,-    Database.PostgreSQL.Migrations,-    Database.PostgreSQL.Sequel,     Web.Simple,     Web.Simple.Auth,+    Web.Simple.Cache,     Web.Simple.Controller,-    Web.Simple.Migrations,     Web.Simple.Responses,-    Web.Simple.Router,     Web.Frank,     Web.REST 

@@ -1,122 +1,58 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-import Prelude hiding (writeFile)+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}++-- | The `smpl` utility for helping a user setup a Simple web project.+module Main (main) where++import Prelude hiding (writeFile, FilePath) import Control.Monad import qualified Data.ByteString.Char8 as S8-import Data.List (sort)-import Data.String-import Filesystem-import Filesystem.Path hiding (concat)-import Filesystem.Path.CurrentOS hiding (concat)-import Language.Haskell.Interpreter hiding (name)-import Network.Wai.Handler.DevelServer (runQuit)+import qualified Data.ByteString.Lazy.Char8 as L8+import qualified Data.ByteString.Lazy.Search as L8 import System.Console.CmdArgs+import System.Directory+import System.FilePath import System.Environment+import System.Process -import Web.Simple.Migrations-import Web.Simple.Router ()+import Paths_simple  data Smpl =     Server       { port :: Int       , moduleName :: String       } |-    New-      { thing :: String-      , newArgs :: [String]} |-    Create { appName :: String } |-    Migrate |-    Rollback-      { steps :: Int }+    Create { appName :: String }     deriving (Show, Data, Typeable)  main :: IO () main = do-    env <- getEnvironment-    let myport = maybe 3000 read $ lookup "PORT" env+    myenv <- getEnvironment+    let myport = maybe 3000 read $ lookup "PORT" myenv     let develMode = cmdArgsMode $ modes                   [ Server { port = myport &= typ "PORT"                            , moduleName = "Main" &= typ "MODULE"                                         &= explicit &= name "module"                            } &= auto-                  , New { thing = "migration" &= argPos 0 &= typ "migration|..."-                        , newArgs = [] &= args }-                  , Create { appName = "" &= argPos 0 &= typ "APP_NAME" }-                  , Migrate-                  , Rollback { steps = 1 &= typ "INTEGER" }]+                  , Create { appName = "" &= argPos 0 &= typ "APP_NAME" } ]     smpl <- cmdArgsRun develMode     case smpl of-      Server p m -> do-        runQuit p m "app" (const $ return [])-        putStrLn $ "Starting server on port " ++ (show myport)-      Rollback steps -> do-        fls <- listDirectory "migrate"-        whileI steps (reverse . sort $ fls) $ \f -> do-          let fileName = encodeString $ filename f-          let version = takeWhile (/= '_') fileName-          let mname = drop 1 $ dropWhile (/= '_') $-                        takeWhile (/= '.') fileName-          runRollback (encodeString f) version mname-      Migrate -> do-        fls <- listDirectory "migrate"-        forM_ (sort fls) $ \f -> do-          let fileName = encodeString $ filename f-          let version = takeWhile (/= '_') fileName-          let mname = drop 1 $ dropWhile (/= '_') $-                        takeWhile (/= '.') fileName-          runMigration (encodeString f) version mname-      New "migration" (name:[]) -> do-        putStrLn $ "Creating migration " ++ name-        newMigration name-      Create appName -> createApplication appName-      otherwise -> return ()-  where whileI 0 _ _ = return ()-        whileI _ [] _ = return ()-        whileI i (f:fs) act = do-          b <- act f-          if b then whileI (i - 1) fs act-            else whileI i fs act--runMigration :: String -> String -> String -> IO Bool-runMigration fileName version mname = do-  eup <- runInterpreter $ do-    loadModules [fileName]-    setImports ["Prelude"]-    setTopLevelModules ["Main"]-    interpret "up" (undefined :: Migration)-  case eup of-    Right up -> do-                  res <- up version mname-                  when res $ putStrLn $ "=== " ++-                      "Finished migration " ++ mname ++ " (" ++ version ++ ")"-                  return res-    Left err -> fail $ show err--runRollback :: String -> String -> String -> IO Bool-runRollback fileName version mname = do-  edown <- runInterpreter $ do-    loadModules [fileName]-    setImports ["Prelude"]-    setTopLevelModules ["Main"]-    interpret "down" (undefined :: Migration)-  case edown of-    Right down -> do-                  res <- down version mname-                  when res $ putStrLn $ "=== " ++-                      "Finished rollback " ++ mname ++ " (" ++ version ++ ")"-                  return res-    Left err -> fail $ show err+      Server p m -> void $+        rawSystem "wai-handler-devel" [show p, m, "app"]+      Create myAppName -> createApplication myAppName  createApplication :: String -> IO ()-createApplication appName = do-  createTree $ fromString appName </> "migrate"-  writeFile (fromString appName </> "Main.hs") mainTemplate+createApplication myAppName = do+  createDirectory myAppName+  let mappings = [("pkgname", myAppName)]+  copyTemplate ("template" </> "Main_hs.tmpl")+               (myAppName </> "Main.hs") mappings+  copyTemplate ("template" </> "package_cabal.tmpl")+               (myAppName </> myAppName ++ ".cabal") mappings -mainTemplate :: S8.ByteString-mainTemplate = S8.concat-  [ "{-# LANGUAGE OverloadedStrings #-}\n\n"-  , "module Main where\n\n"-  , "import Web.Simple\n\n"-  , "app runner = runner $ mkRouter $ do\n"-  , "               routeAll $ okHtml \"Hello World\"\n\n"]+copyTemplate :: FilePath -> FilePath -> [(String, String)] -> IO ()+copyTemplate orig target mappings = do+  tmpl <- getDataFileName orig >>= L8.readFile+  L8.writeFile target $+    (flip . flip foldl) tmpl mappings $ \accm (key, val) ->+      L8.replace (S8.pack $ "{{" ++ key ++ "}}") (L8.pack val) accm 

@@ -0,0 +1,17 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where+import Web.Simple+import Network.Wai.Handler.Warp+import System.Posix.Env++app runner = do+  -- TODO: App initialization code goes here+  runner $ controllerApp () $ do+    -- TODO: routes go here+    respond $ okHtml "Hello World"++main :: IO ()+main = do+  port <- read `fmap` getEnvDefault "PORT" "3000"+  app (run port)+

@@ -0,0 +1,18 @@+name:                {{pkgname}}+version:             0.0.0.0+--author:              YOUR NAME+--maintainer:          your@email.com+category:            Web+build-type:          Simple+cabal-version:       >=1.8++executable {{pkgname}}+  main-is: Main.hs+  ghc-options: -threaded -O2+  build-depends:+    base+    , simple >= 0.5.0+    , unix+    , wai+    , warp+