packages feed

simple 0.2.0 → 0.3.0

raw patch · 7 files changed

+509/−5 lines, 7 filesdep +base64-bytestringdep +mtldep +network

Dependencies added: base64-bytestring, mtl, network, postgresql-simple

Files

+ Database/Connection.hs view
@@ -0,0 +1,47 @@+module Database.Connection where++import Control.Monad.IO.Class (liftIO, MonadIO)+import Control.Concurrent+import Control.Exception (finally)+import Database.PostgreSQL.Simple+import Network.URI+import System.IO.Unsafe++{-# NOINLINE conns #-}+conns :: Chan Connection+conns = unsafePerformIO $ newChan++createConnection :: ConnectInfo -> IO ()+createConnection config = connect config >>= writeChan conns++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 => (Connection -> IO b) -> m b+withConnection func = liftIO $ do+  conn <- readChan conns+  finally (func conn) (writeChan conns conn)+
+ Database/Migrations.hs view
@@ -0,0 +1,23 @@+module Database.Migrations+  ( defaultMain+  , module Database.Sequel+  ) where++import Prelude hiding (catch)+import Control.Exception+import Database.Connection+import Database.Sequel+import Database.PostgreSQL.Simple+import System.Environment++defaultMain :: Sequel () -> Sequel () -> IO ()+defaultMain up down = do+  dbURI <- catch (getEnv "DATABASE_URL")+            (const $ return "postgres://" :: SomeException -> IO String)+  createConnection $ parseDbURL dbURI++  args <- getArgs+  case args of+    "--rollback":_ -> runSequel down >>= withConnection . (flip execute_)+    _ -> runSequel up >>= withConnection . (flip execute_)+  return ()
+ Database/PostgreSQL/Models.hs view
@@ -0,0 +1,253 @@+{-# 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)++  -- | 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+
+ Database/Sequel.hs view
@@ -0,0 +1,110 @@+module Database.Sequel where++import Control.Monad.State+import Data.List+import Data.String++type Sequel = StateT String IO++runSequel :: IsString s => Sequel a -> IO s+runSequel sql = fmap (fromString . snd) $ runStateT sql ""++append :: String -> Sequel ()+append str1 = modify $ \str0 -> concat $+  [ str0+  , "\n\n"+  , str1]++drop_table :: String -> Sequel ()+drop_table name = append $ "DROP TABLE " ++ name ++ ";"++create_table :: String -> CreateTable a -> Sequel ()+create_table name block = do+  blk <- runCreateTable $ do+    block+  append $ concat $+    [ "CREATE TABLE " ++ name ++ " (\n"+    , blk+    , "\n);"]++type ColumnType = String++serial :: ColumnType+serial = "serial"++integer :: ColumnType+integer = "integer"++time :: ColumnType+time = "time"++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 = append $ concat $+  [ "ALTER TABLE "+  , tableName+  , " DROP COLUMN "+  , colName, ";"]++add_column :: String -> String -> ColumnType -> [ColumnConstraint] -> Sequel ()+add_column tableName colName colType ctrs = append $ concat $+  [ "ALTER TABLE "+  , tableName+  , " ADD COLUMN "+  , colName+  , " "+  , colType+  , " "+  , concat $ intersperse " " (map stringifyConstraint ctrs), ";"]++rename_column :: String -> String -> String -> Sequel ()+rename_column tableName fromName toName = append $ concat $+  [ "ALTER TABLE "+  , tableName+  , " RENAME COLUMN "+  , fromName+  , " TO "+  , toName+  , ";"]++type CreateTable = StateT [(ColumnType, String, [ColumnConstraint])] Sequel++runCreateTable :: CreateTable a -> Sequel String+runCreateTable ct = 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+
+ Web/Simple/Auth.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings, Rank2Types #-}+module Web.Simple.Auth where++import Control.Monad.IO.Class (liftIO)+import Data.ByteString.Base64+import qualified Data.ByteString.Char8 as S8+import Network.HTTP.Types+import Network.Wai+import Web.Simple.Responses+import Web.Simple.Router++-- | 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 ()++-- | 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+  ) ()++-- | 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 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)}++-- | 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)+
Web/Simple/Router.hs view
@@ -35,7 +35,6 @@ 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'.@@ -176,7 +175,7 @@ routePattern :: Routeable r => S.ByteString -> r -> Route () routePattern pattern route =   let patternParts = map T.unpack $ decodePathSegments pattern-  in routeTop $ foldr mkRoute (mroute . runRoute $ route) patternParts+  in foldr mkRoute (mroute . runRoute $ routeTop route) patternParts   where mkRoute (':':varName) = routeVar (S8.pack varName)         mkRoute varName = routeName (S8.pack varName)
simple.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                simple-version:             0.2.0+version:             0.3.0 synopsis: A minimalist web framework for the WAI server interface description: @@ -48,18 +48,27 @@ library   build-depends:     base >=4.5 && < 5.0,+    base64-bytestring >= 1.0 && < 1.1,     conduit >= 0.5,     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+    bytestring >= 0.9,+    postgresql-simple >= 0.2.4.1,+    network >= 2.4,+    mtl >= 2.1 -  ghc-options: -Wall+  ghc-options: -Wall -fno-warn-unused-do-bind    exposed-modules:+    Database.PostgreSQL.Models,+    Database.Connection,+    Database.Migrations,+    Database.Sequel,     Web.Simple,+    Web.Simple.Auth,     Web.Simple.Controller,     Web.Simple.Responses,     Web.Simple.Router,