diff --git a/Database/Connection.hs b/Database/Connection.hs new file mode 100644 --- /dev/null +++ b/Database/Connection.hs @@ -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) + diff --git a/Database/Migrations.hs b/Database/Migrations.hs new file mode 100644 --- /dev/null +++ b/Database/Migrations.hs @@ -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 () diff --git a/Database/PostgreSQL/Models.hs b/Database/PostgreSQL/Models.hs new file mode 100644 --- /dev/null +++ b/Database/PostgreSQL/Models.hs @@ -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 + diff --git a/Database/Sequel.hs b/Database/Sequel.hs new file mode 100644 --- /dev/null +++ b/Database/Sequel.hs @@ -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 + diff --git a/Web/Simple/Auth.hs b/Web/Simple/Auth.hs new file mode 100644 --- /dev/null +++ b/Web/Simple/Auth.hs @@ -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) + diff --git a/Web/Simple/Router.hs b/Web/Simple/Router.hs --- a/Web/Simple/Router.hs +++ b/Web/Simple/Router.hs @@ -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) diff --git a/simple.cabal b/simple.cabal --- a/simple.cabal +++ b/simple.cabal @@ -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,