simple 0.3.0 → 0.4.0
raw patch · 13 files changed
+476/−198 lines, 13 filesdep +attoparsecdep +cmdargsdep +hintnew-component:exe:smpl
Dependencies added: attoparsec, cmdargs, hint, old-locale, old-time, resource-pool, resourcet, system-fileio, system-filepath, wai-handler-devel
Files
- Database/Connection.hs +0/−47
- Database/Migrations.hs +0/−23
- Database/PostgreSQL/Connection.hs +58/−0
- Database/PostgreSQL/Migrations.hs +58/−0
- Database/PostgreSQL/Models.hs +14/−0
- Database/PostgreSQL/Sequel.hs +129/−0
- Database/Sequel.hs +0/−110
- Web/REST.hs +13/−10
- Web/Simple/Controller.hs +16/−3
- Web/Simple/Migrations.hs +27/−0
- Web/Simple/Responses.hs +6/−1
- simple.cabal +33/−4
- smpl.hs +122/−0
− Database/Connection.hs
@@ -1,47 +0,0 @@-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
@@ -1,23 +0,0 @@-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/Connection.hs view
@@ -0,0 +1,58 @@+{-# 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+
+ Database/PostgreSQL/Migrations.hs view
@@ -0,0 +1,58 @@+{-# 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+
Database/PostgreSQL/Models.hs view
@@ -116,6 +116,20 @@ 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)
+ Database/PostgreSQL/Sequel.hs view
@@ -0,0 +1,129 @@+{-# 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 ()+
− Database/Sequel.hs
@@ -1,110 +0,0 @@-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/REST.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances, OverloadedStrings #-} module Web.REST- ( RESTController+ ( REST(..), RESTController, rest , index, show, create, update, delete , edit, new ) where@@ -8,12 +8,12 @@ import Prelude hiding (show) import Control.Monad.Trans.State-import Data.Conduit+import Control.Monad.Identity import Web.Simple.Responses import Web.Simple.Router import Network.HTTP.Types -data RESTControllerState = RESTControllerState+data REST = REST { restIndex :: Route () , restShow :: Route () , restCreate :: Route ()@@ -23,8 +23,8 @@ , restNew :: Route () } -defaultRESTControllerState :: RESTControllerState-defaultRESTControllerState = RESTControllerState+defaultREST :: REST+defaultREST = REST { restIndex = routeAll $ notFound , restShow = routeAll $ notFound , restCreate = routeAll $ notFound@@ -34,7 +34,7 @@ , restNew = routeAll $ notFound } -instance Routeable RESTControllerState where+instance Routeable REST where runRoute controller = runRoute $ do routeMethod GET $ do routeTop $ restIndex controller@@ -45,17 +45,20 @@ routeMethod POST $ routeTop $ restCreate controller - routeMethod PUT $ routeVar "id" $ restUpdate controller- routeMethod DELETE $ routeVar "id" $ restDelete controller -type RESTControllerM a = StateT RESTControllerState (ResourceT IO) a+ routeMethod PUT $ routeVar "id" $ restUpdate controller +type RESTControllerM a = StateT REST Identity a+ instance Routeable (RESTControllerM a) where runRoute controller = rt where rt req = do- (_, st) <- runStateT controller defaultRESTControllerState+ let (_, st) = runIdentity $ runStateT controller defaultREST runRoute st req++rest :: RESTControllerM a -> REST+rest controller = snd . runIdentity $ runStateT controller defaultREST type RESTController = RESTControllerM ()
Web/Simple/Controller.hs view
@@ -87,13 +87,26 @@ -- @ -- -- would return /Nothing/-queryParam :: S8.ByteString -- ^ Parameter name- -> Controller (Maybe S8.ByteString)+queryParam :: Parseable a => S8.ByteString -- ^ Parameter name+ -> Controller (Maybe a) queryParam varName = do qr <- fmap queryString request case lookup varName qr of- Just n -> return n+ Just p -> return $ fmap parse p _ -> return Nothing++class Parseable a where+ parse :: S8.ByteString -> a++instance Parseable S8.ByteString where+ parse = id+instance Parseable String where+ parse = S8.unpack+instance Parseable Integer where+ parse = parseReadable++parseReadable :: Read a => S8.ByteString -> a+parseReadable = read . S8.unpack -- | 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
+ Web/Simple/Migrations.hs view
@@ -0,0 +1,27 @@+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"]+
Web/Simple/Responses.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -- | This module defines some convenience functions for creating responses. module Web.Simple.Responses- ( ok, okHtml+ ( ok, okHtml, okJson , movedTo, redirectTo , badRequest, requireBasicAuth, forbidden , notFound@@ -32,6 +32,11 @@ okHtml :: L8.ByteString -> Response okHtml body = mkHtmlResponse status200 [] body++-- | Creates a 200 (OK) 'Response' with content-type \"application/json\" and the+-- given resposne body+okJson :: L8.ByteString -> Response+okJson = ok (S8.pack "application/json") -- | Given a URL returns a 301 (Moved Permanently) 'Response' redirecting to -- that URL.
simple.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: simple-version: 0.3.0+version: 0.4.0 synopsis: A minimalist web framework for the WAI server interface description: @@ -45,11 +45,37 @@ build-type: Simple cabal-version: >=1.9.2 +executable smpl+ Main-Is: smpl.hs+ 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+ 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,@@ -57,6 +83,8 @@ 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 @@ -64,12 +92,13 @@ exposed-modules: Database.PostgreSQL.Models,- Database.Connection,- Database.Migrations,- Database.Sequel,+ Database.PostgreSQL.Connection,+ Database.PostgreSQL.Migrations,+ Database.PostgreSQL.Sequel, Web.Simple, Web.Simple.Auth, Web.Simple.Controller,+ Web.Simple.Migrations, Web.Simple.Responses, Web.Simple.Router, Web.Frank,
+ smpl.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+import Prelude hiding (writeFile)+import Control.Monad+import qualified Data.ByteString.Char8 as S8+import Data.List (sort)+import Data.String+import Filesystem hiding (concat)+import Filesystem.Path hiding (concat)+import Filesystem.Path.CurrentOS hiding (concat)+import Language.Haskell.Interpreter hiding (name)+import Network.Wai.Handler.DevelServer (runQuit)+import System.Console.CmdArgs+import System.Environment++import Web.Simple.Migrations+import Web.Simple.Router ()++data Smpl =+ Server+ { port :: Int+ , moduleName :: String+ } |+ New+ { thing :: String+ , newArgs :: [String]} |+ Create { appName :: String } |+ Migrate |+ Rollback+ { steps :: Int }+ deriving (Show, Data, Typeable)++main :: IO ()+main = do+ env <- getEnvironment+ let myport = maybe 3000 read $ lookup "PORT" env+ 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" }]+ 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++createApplication :: String -> IO ()+createApplication appName = do+ createTree $ fromString appName </> "migrate"+ writeFile (fromString appName </> "Main.hs") mainTemplate++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"]+