snap-core-0.2.2: src/Snap/Starter.hs
module Main where
------------------------------------------------------------------------------
import System
import System.Directory
import System.Console.GetOpt
import System.FilePath.Posix
------------------------------------------------------------------------------
------------------------------------------------------------------------------
usage :: String
usage = unlines
["Usage:"
,""
," snap <action>"
,""
," <action> can be one of:"
," init - create a new project directory structure in the current directory"
]
------------------------------------------------------------------------------
data InitFlag = InitBareBones
| InitHelp
deriving (Show, Eq)
------------------------------------------------------------------------------
initProject :: [String] -> IO ()
initProject args = do
case getOpt Permute options args of
(flags, _, [])
| InitHelp `elem` flags -> do putStrLn initUsage
exitFailure
| otherwise -> init' (InitBareBones `elem` flags)
(_, _, errs) -> do putStrLn $ concat errs
putStrLn initUsage
exitFailure
where
initUsage = unlines
["Usage:"
,""
," snap init"
,""
," -b --barebones Depend only on -core and -server"
," -h --help Print this message"
]
options =
[ Option ['b'] ["barebones"] (NoArg InitBareBones)
"Depend only on -core and -server"
, Option ['h'] ["help"] (NoArg InitHelp)
"Print this message"
]
init' isBareBones = do
cur <- getCurrentDirectory
let dirs = splitDirectories cur
projName = last dirs
writeFile (projName++".cabal") (cabalFile projName isBareBones)
createDirectory "src"
writeFile "src/Main.hs" (mainFile isBareBones)
------------------------------------------------------------------------------
main :: IO ()
main = do
args <- getArgs
case args of
("init":args') -> initProject args'
_ -> do putStrLn usage
exitFailure
------------------------------------------------------------------------------
cabalFile :: String -> Bool -> String
cabalFile projName isBareBones = unlines $
["Name: "++projName
,"Version: 0.1"
,"Synopsis: Project Synopsis Here"
,"Description: Project Description Here"
,"License: AllRightsReserved"
,"Author: Author"
,"Maintainer: maintainer@example.com"
,"Stability: Experimental"
,"Category: Web"
,"Build-type: Simple"
,"Cabal-version: >=1.2"
,""
,"Executable "++projName
," hs-source-dirs: src"
," main-is: Main.hs"
,""
," Build-depends:"
," base >= 4,"
," haskell98,"
," monads-fd >= 0.1 && <0.2,"
," bytestring >= 0.9.1 && <0.10,"
," snap-core >= 0.2 && <0.3,"
," snap-server >= 0.2 && <0.3,"
] ++ (if isBareBones then [] else [" heist >= 0.1 && <0.2,"]) ++
[" filepath >= 1.1 && <1.2"
,""
," ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded -fno-warn-unused-imports"
]
------------------------------------------------------------------------------
mainFile :: Bool -> String
mainFile isBareBones = unlines $
["{-# LANGUAGE OverloadedStrings #-}"
,"module Main where"
,""
,"import System"
,"import Control.Applicative"
,"import Control.Monad.Trans"
,"import Snap.Http.Server"
,"import Snap.Types"
,"import Snap.Util.FileServe"
] ++ (if isBareBones then [] else ["import Text.Templating.Heist"]) ++
[""
,"site :: Snap ()"
,"site ="
," ifTop (writeBS \"hello world\") <|>"
," fileServe \".\""
,""
,"main :: IO ()"
,"main = do"
," args <- getArgs"
," let port = case args of"
," [] -> 8000"
," p:_ -> read p"
," httpServe \"*\" port \"myserver\""
," (Just \"access.log\")"
," (Just \"error.log\")"
," site"
]