haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Validate input params before processing

Browse Source
This commit is contained in:
Ilya Smelkov 2015-05-10 21:27:00 +03:00
parent ce268e451d
commit 50f0859e13
2 changed files with 58 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

103
yesod-bin/Scaffolding/Scaffolder.hs
View File

@ -5,7 +5,8 @@ module Scaffolding.Scaffolder (scaffold, backendOptions) where
import Control.Arrow ((&&&))
import qualified Data.ByteString.Char8 as S
import Data.Conduit (yield, ($$), ($$+-))
import Control.Monad.Trans.Resource (runResourceT)
import Control.Monad.Trans.Resource (runResourceT)
import Control.DeepSeq (($!!), NFData)
import Data.FileEmbed (embedFile)
import Data.String (fromString)
import qualified Data.Text as T
@ -15,7 +16,7 @@ import Text.ProjectTemplate (unpackTemplate, receiveFS)
import System.IO
import Text.Shakespeare.Text (renderTextUrl, textFile)
import Network.HTTP.Conduit (Request, withManager, http, parseUrl, responseBody)
import Data.Maybe (isJust, fromJust)
import Data.Maybe (isJust)
import Data.List (intercalate)
import Distribution.Text (simpleParse)
import Distribution.Package (PackageName)
@ -30,6 +31,12 @@ prompt f = do
hFlush stdout
prompt f
data BackendInput = BIUrl
| BIBackend Backend
| BIUndefined
instance NFData BackendInput
data Backend = Sqlite
| Postgresql
| PostgresqlFay
@ -85,53 +92,57 @@ scaffold :: Bool -- ^ bare directory instead of a new subdirectory?
-> Maybe String -- ^ application name
-> Maybe String -- ^ database
-> IO ()
scaffold isBare appName database = do
puts $ renderTextUrl undefined $(textFile "input/welcome.cg")
project <- projectName appName
ebackend <- projectDatabase database
scaffold isBare appName appDatabase = (requestMissing $!! validatedInput) >>= unpack
where
validatedInput :: (Maybe String, BackendInput)
validatedInput = (name, db)
where
name = fmap (\ s -> if validPackageName s then s else error "Invalid value for --name option.") appName
db = maybe BIUndefined validateDB appDatabase
where
validateDB "url" = BIUrl
validateDB s = maybe (error "Invalid value for --database option.") BIBackend (readBackend inputBackend s)
putStrLn "That's it! I'm creating your files now..."
requestMissing :: (Maybe String, BackendInput) -> IO (String, Either Request Backend)
requestMissing (name, database) = do
puts $ renderTextUrl undefined $(textFile "input/welcome.cg")
project <- maybe promptName return name
ebackend <- backend database
return (project, ebackend)
where
promptName = do
puts $ renderTextUrl undefined $(textFile "input/project_name.cg")
prompt $ \s -> if validPackageName s then Just s else Nothing
let sink = unpackTemplate
(receiveFS $ if isBare then "." else fromString project)
( T.replace "PROJECTNAME" (T.pack project)
. T.replace "PROJECTNAME_LOWER" (T.toLower $ T.pack project)
)
case ebackend of
Left req -> withManager $ \m -> do
res <- http req m
responseBody res $$+- sink
Right backend -> runResourceT $ yield (backendBS backend) $$ sink
backend :: BackendInput -> IO (Either Request Backend)
backend (BIBackend back) = return $ Right back
backend BIUndefined = do
puts $ renderTextUrl undefined $(textFile "input/database.cg")
ebackend' <- prompt $ \s -> if s == "url" then Just (Left ()) else fmap Right $ readBackend showBackend s
case ebackend' of
Left () -> requestUrl
Right back -> return $ Right back
backend BIUrl = requestUrl
let projectnameReplacer = if isBare
then LT.replace "cd PROJECTNAME && " ""
else LT.replace "PROJECTNAME" (LT.pack project)
TLIO.putStr $ projectnameReplacer $ renderTextUrl undefined $(textFile "input/done.cg")
projectDatabase :: Maybe String -- ^ database
-> IO (Either Request Backend)
projectDatabase Nothing = do
puts $ renderTextUrl undefined $(textFile "input/database.cg")
ebackend' <- prompt $ \s -> if s == "url" then Just (Left ()) else fmap Right $ readBackend showBackend s
case ebackend' of
Left () -> do
requestUrl = do
puts "Please enter the URL: "
fmap Left $ prompt parseUrl
Right backend -> return $ Right backend
projectDatabase (Just db)
| "url" == db = do
puts "Please enter the URL: "
fmap Left $ prompt parseUrl
| isJust parsedDB = return $ Right (fromJust parsedDB)
| otherwise = error "Invalid value for --database option."
where
parsedDB = readBackend inputBackend db
projectName :: Maybe String -- ^ application name
-> IO String
projectName Nothing = do
puts $ renderTextUrl undefined $(textFile "input/project_name.cg")
prompt $ \s -> if validPackageName s then Just s else Nothing
projectName (Just name) | validPackageName name = return name
| otherwise = error "Invalid value for --name option."
unpack :: (String, Either Request Backend) -> IO ()
unpack (project, ebackend) = do
putStrLn "That's it! I'm creating your files now..."
case ebackend of
Left req -> withManager $ \m -> do
res <- http req m
responseBody res $$+- sink
Right backend -> runResourceT $ yield (backendBS backend) $$ sink
TLIO.putStr $ projectnameReplacer $ renderTextUrl undefined $(textFile "input/done.cg")
where
sink = unpackTemplate
(receiveFS $ if isBare then "." else fromString project)
( T.replace "PROJECTNAME" (T.pack project)
. T.replace "PROJECTNAME_LOWER" (T.toLower $ T.pack project)
)
projectnameReplacer = if isBare
then LT.replace "cd PROJECTNAME && " ""
else LT.replace "PROJECTNAME" (LT.pack project)

1
yesod-bin/yesod-bin.cabal
View File

@ -90,6 +90,7 @@ executable yesod
, streaming-commons
, warp-tls >= 3.0.1
, async
, deepseq
ghc-options: -Wall -threaded -rtsopts
main-is: main.hs