modularized
This commit is contained in:
parent
f379110385
commit
36398843b7
5 changed files with 179 additions and 156 deletions
|
@ -1,18 +1,18 @@
|
|||
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
module HolyProject where
|
||||
import HolyProject.Swallow ()
|
||||
import HolyProject.Coconut ()
|
||||
import HolyProject.GitConfig ( getNameAndMailFromGitConfig)
|
||||
import HolyProject.StringUtils ( projectNameFromString
|
||||
, capitalize
|
||||
, checkProjectName)
|
||||
import HolyProject.GitHubAPI ( searchGHUserFromEmail)
|
||||
import HolyProject.MontyPython ( bk
|
||||
, you
|
||||
, ask
|
||||
)
|
||||
|
||||
-- Project name manipulation
|
||||
import Data.Char (toUpper,toLower,isLetter,isNumber)
|
||||
import Data.List (intersperse)
|
||||
import Data.List.Split (splitOneOf)
|
||||
-- Get current year for the License
|
||||
import Data.Time.Clock
|
||||
import Data.Time.Calendar
|
||||
-- Console read write with colors
|
||||
import System.Console.ANSI
|
||||
import System.IO (hFlush, stdout)
|
||||
-- Hastache
|
||||
import Data.Data
|
||||
import Text.Hastache
|
||||
|
@ -26,22 +26,8 @@ import System.FilePath.Posix (takeDirectory,(</>))
|
|||
import System.Cmd (system)
|
||||
-- Random error message :)
|
||||
import System.Random
|
||||
--- Environment variable
|
||||
import System.Environment (getEnv)
|
||||
import Data.Maybe (fromJust)
|
||||
import Control.Exception
|
||||
import System.IO.Error
|
||||
import Control.Monad (guard)
|
||||
-- HTTP request and JSON handling
|
||||
import Network.HTTP.Conduit
|
||||
import Control.Lens.Operators ((^?))
|
||||
import Control.Lens.Aeson
|
||||
import Data.Aeson.Encode (fromValue)
|
||||
import qualified Data.Text.Lazy as TLZ
|
||||
import qualified Data.Text.Lazy.Builder as TLB
|
||||
-- Fork
|
||||
import Control.Concurrent
|
||||
|
||||
-- Get external file of package
|
||||
import Paths_holy_project
|
||||
|
||||
|
@ -55,7 +41,7 @@ data Project = Project {
|
|||
, synopsis :: String
|
||||
, year :: String } deriving (Data, Typeable)
|
||||
|
||||
-- | Error message
|
||||
-- | Randomly choose an end scenario and then show a "serious" error message
|
||||
holyError :: String -> IO ()
|
||||
holyError str = do
|
||||
r <- randomIO
|
||||
|
@ -80,28 +66,15 @@ ioassert :: Bool -> String -> IO ()
|
|||
ioassert True _ = return ()
|
||||
ioassert False str = holyError str
|
||||
|
||||
-- | return the content of ~/.gitconfig if it exists
|
||||
-- if the HOME environment variable is not set
|
||||
-- or the file doesn't exists
|
||||
-- We return an empty string
|
||||
safeReadGitConfig :: IO LZ.ByteString
|
||||
safeReadGitConfig = do
|
||||
e <- tryJust (guard . isDoesNotExistError)
|
||||
(do
|
||||
home <- getEnv "HOME"
|
||||
LZ.readFile $ home ++ "/.gitconfig" )
|
||||
return $ either (const (LZ.empty)) id e
|
||||
|
||||
-- | Ask, questions and create the initial project
|
||||
holyStarter :: IO ()
|
||||
holyStarter = do
|
||||
intro
|
||||
gitconfig <- safeReadGitConfig
|
||||
(name,email) <- getNameAndMailFromGitConfig
|
||||
earlyhint <- newEmptyMVar
|
||||
let (name,email) = getNameAndMail gitconfig
|
||||
maybe (putMVar earlyhint Nothing) -- if no email found put Nothing
|
||||
(\hintmail -> do -- in the other case ask the github API
|
||||
forkIO (putMVar earlyhint =<< getGHUser hintmail)
|
||||
forkIO (putMVar earlyhint =<< searchGHUserFromEmail hintmail)
|
||||
>> return ())
|
||||
email
|
||||
project <- ask "project name" Nothing
|
||||
|
@ -112,7 +85,7 @@ holyStarter = do
|
|||
in_author <- ask "name" name
|
||||
in_email <- ask "email" email
|
||||
ghUserHint <- if (maybe "" id email) /= in_email
|
||||
then getGHUser in_email
|
||||
then searchGHUserFromEmail in_email
|
||||
else takeMVar earlyhint
|
||||
in_ghaccount <- ask "github account" ghUserHint
|
||||
in_synopsis <- ask "project in less than a dozen word?" Nothing
|
||||
|
@ -127,26 +100,6 @@ getCurrentYear = do
|
|||
(current_year,_,_) <- getCurrentTime >>= return . toGregorian . utctDay
|
||||
return (show current_year)
|
||||
|
||||
-- | bridgekeeper speak
|
||||
bk :: String -> IO ()
|
||||
bk str = colorPutStr Green ("Bridgekeeper: " ++ str ++ "\n")
|
||||
-- | bridgekeeper speak without line return
|
||||
bkn :: String -> IO ()
|
||||
bkn str = colorPutStr Green ("Bridgekeeper: " ++ str)
|
||||
-- | the user dialog
|
||||
you :: String -> IO ()
|
||||
you str = colorPutStr Yellow ("Bridgekeeper: " ++ str ++ "\n")
|
||||
|
||||
-- | show color
|
||||
colorPutStr :: Color -> String -> IO ()
|
||||
colorPutStr color str = do
|
||||
setSGR [ SetColor Foreground Dull color
|
||||
, SetConsoleIntensity NormalIntensity
|
||||
]
|
||||
putStr str
|
||||
setSGR []
|
||||
|
||||
|
||||
-- | Show an introduction test
|
||||
intro :: IO ()
|
||||
intro = do
|
||||
|
@ -168,38 +121,6 @@ end = do
|
|||
putStrLn "Sir Bedevere: How do you know so much about swallows?"
|
||||
you "Well, you have to know these things when you're a king, you know."
|
||||
|
||||
-- | Ask for some info and returns it
|
||||
ask :: String -- ^ What? "name" for example
|
||||
-> Maybe String -- ^ Default value
|
||||
-> IO String
|
||||
ask info hint = do
|
||||
bk $ "What is your " ++ info ++ "?" ++
|
||||
(maybe "" (\h -> " ("++h++")") hint)
|
||||
putStr "> "
|
||||
hFlush stdout
|
||||
answer <- getLine
|
||||
putStrLn ""
|
||||
return $ if (answer == "") && (hint /= Nothing)
|
||||
then fromJust hint
|
||||
else answer
|
||||
|
||||
-- | verify if a project name is conform
|
||||
checkProjectName :: String -> Bool
|
||||
checkProjectName [] = False
|
||||
checkProjectName str = all (\c -> (isLetter c)||(isNumber c)||(c=='-')||(c==' ')) str
|
||||
|
||||
-- | transform a chain like "Holy project" in "holy-project"
|
||||
projectNameFromString :: String -> String
|
||||
projectNameFromString str = concat $ intersperse "-" (splitOneOf " -" (map toLower str))
|
||||
|
||||
-- | transform a chain like "Holy project" in "HolyProject"
|
||||
capitalize :: String -> String
|
||||
capitalize str = concat (map capitalizeWord (splitOneOf " -" str))
|
||||
where
|
||||
capitalizeWord :: String -> String
|
||||
capitalizeWord (x:xs) = (toUpper x):map toLower xs
|
||||
capitalizeWord _ = []
|
||||
|
||||
-- | This function use a Data file mustache template
|
||||
-- and a hastache context to write a destination file
|
||||
genFile :: MuContext IO -- ^ hastache context
|
||||
|
@ -273,66 +194,3 @@ createProject p = do
|
|||
_ <- system "cabal test"
|
||||
_ <- system $ "./.cabal-sandbox/bin/test-" ++ (projectName p)
|
||||
return ()
|
||||
|
||||
|
||||
-- | Returns the name and email from the content of a .gitconfig file
|
||||
-- almost equivalent to the two zsh lines:
|
||||
--
|
||||
-- > name="$(< ~/.gitconfig awk '$1 == name {shift 2; print}')"
|
||||
-- > email="$(< ~/.gitconfig awk '$1 == email {shift 2; print}')"
|
||||
--
|
||||
-- But in Haskell it doesn't read the entire file.
|
||||
-- The script after the first occurence of name and email.
|
||||
getNameAndMail :: LZ.ByteString -> (Maybe String,Maybe String)
|
||||
getNameAndMail gitConfigContent = (getFirstValueFor splitted "name",
|
||||
getFirstValueFor splitted "email")
|
||||
where
|
||||
-- make lines of words
|
||||
splitted :: [[LZ.ByteString]]
|
||||
splitted = map LZ.words (LZ.lines gitConfigContent)
|
||||
|
||||
-- | Get the first line which start with
|
||||
-- 'elem =' and return the third field (value)
|
||||
getFirstValueFor :: [[LZ.ByteString]] -> String -> Maybe String
|
||||
getFirstValueFor splitted keyname = firstJust (map (getValueForKey keyname) splitted)
|
||||
|
||||
-- | return the first Just value of a list of Maybe
|
||||
firstJust :: (Eq a) => [Maybe a] -> Maybe a
|
||||
firstJust l = case dropWhile (==Nothing) l of
|
||||
[] -> Nothing
|
||||
(j:_) -> j
|
||||
|
||||
-- | Given a line of words ("word1":"word2":rest)
|
||||
-- getValue will return rest if word1 == key
|
||||
-- 'elem =' or Nothing otherwise
|
||||
getValueForKey :: String -- key
|
||||
-> [LZ.ByteString] -- line of words
|
||||
-> Maybe String -- the value if found
|
||||
getValueForKey el (n:e:xs) = if (n == (LZ.pack el)) && (e == (LZ.pack "="))
|
||||
then Just (LZ.unpack (LZ.unwords xs))
|
||||
else Nothing
|
||||
getValueForKey _ _ = Nothing
|
||||
|
||||
-- | make a simple http request but add a user agent to the HTTP header
|
||||
simpleHTTPWithUserAgent :: String -> IO LZ.ByteString
|
||||
simpleHTTPWithUserAgent url = do
|
||||
r <- parseUrl url
|
||||
let request = r { requestHeaders = [ ("User-Agent","HTTP-Conduit") ] }
|
||||
body <- withManager $ \manager -> do
|
||||
response <- httpLbs request manager
|
||||
return $ responseBody response
|
||||
return body
|
||||
|
||||
|
||||
-- | Ask the github API
|
||||
-- A strange behaviour you HAVE TO add a User-Agent in your header.
|
||||
-- It took me way too long to get this error
|
||||
getGHUser :: String -> IO (Maybe String)
|
||||
getGHUser "" = return Nothing
|
||||
getGHUser email = do
|
||||
let url = "https://api.github.com/search/users?q=" ++ email
|
||||
body <- simpleHTTPWithUserAgent url
|
||||
login <- return $ body ^? key "items" . nth 0 . key "login"
|
||||
return $ fmap jsonValueToString login
|
||||
where
|
||||
jsonValueToString = TLZ.unpack . TLB.toLazyText . fromValue
|
||||
|
|
65
src/HolyProject/GitConfig.hs
Normal file
65
src/HolyProject/GitConfig.hs
Normal file
|
@ -0,0 +1,65 @@
|
|||
module HolyProject.GitConfig
|
||||
( getNameAndMailFromGitConfig
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.ByteString.Lazy.Char8 as LZ
|
||||
import Control.Monad (guard)
|
||||
import Control.Exception
|
||||
import System.IO.Error
|
||||
import System.Environment (getEnv)
|
||||
|
||||
-- | Return name and email in gitconfig if found
|
||||
getNameAndMailFromGitConfig :: IO (Maybe String, Maybe String)
|
||||
getNameAndMailFromGitConfig = return . getNameAndMail =<< safeReadGitConfig
|
||||
|
||||
-- | return the content of ~/.gitconfig if it exists
|
||||
-- if the HOME environment variable is not set
|
||||
-- or the file doesn't exists
|
||||
-- We return an empty string
|
||||
safeReadGitConfig :: IO LZ.ByteString
|
||||
safeReadGitConfig = do
|
||||
e <- tryJust (guard . isDoesNotExistError)
|
||||
(do
|
||||
home <- getEnv "HOME"
|
||||
LZ.readFile $ home ++ "/.gitconfig" )
|
||||
return $ either (const (LZ.empty)) id e
|
||||
|
||||
-- | Returns the name and email from the content of a .gitconfig file
|
||||
-- almost equivalent to the two zsh lines:
|
||||
--
|
||||
-- > name="$(< ~/.gitconfig awk '$1 == name {shift 2; print}')"
|
||||
-- > email="$(< ~/.gitconfig awk '$1 == email {shift 2; print}')"
|
||||
--
|
||||
-- But in Haskell it doesn't read the entire file.
|
||||
-- The script after the first occurence of name and email.
|
||||
getNameAndMail :: LZ.ByteString -> (Maybe String,Maybe String)
|
||||
getNameAndMail gitConfigContent = (getFirstValueFor splitted "name",
|
||||
getFirstValueFor splitted "email")
|
||||
where
|
||||
-- make lines of words
|
||||
splitted :: [[LZ.ByteString]]
|
||||
splitted = map LZ.words (LZ.lines gitConfigContent)
|
||||
|
||||
-- | Get the first line which start with
|
||||
-- 'elem =' and return the third field (value)
|
||||
getFirstValueFor :: [[LZ.ByteString]] -> String -> Maybe String
|
||||
getFirstValueFor splitted keyname = firstJust (map (getValueForKey keyname) splitted)
|
||||
|
||||
-- | return the first Just value of a list of Maybe
|
||||
firstJust :: (Eq a) => [Maybe a] -> Maybe a
|
||||
firstJust l = case dropWhile (==Nothing) l of
|
||||
[] -> Nothing
|
||||
(j:_) -> j
|
||||
|
||||
-- | Given a line of words ("word1":"word2":rest)
|
||||
-- getValue will return rest if word1 == key
|
||||
-- 'elem =' or Nothing otherwise
|
||||
getValueForKey :: String -- key
|
||||
-> [LZ.ByteString] -- line of words
|
||||
-> Maybe String -- the value if found
|
||||
getValueForKey el (n:e:xs) = if (n == (LZ.pack el)) && (e == (LZ.pack "="))
|
||||
then Just (LZ.unpack (LZ.unwords xs))
|
||||
else Nothing
|
||||
getValueForKey _ _ = Nothing
|
||||
|
34
src/HolyProject/GitHubAPI.hs
Normal file
34
src/HolyProject/GitHubAPI.hs
Normal file
|
@ -0,0 +1,34 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module HolyProject.GitHubAPI where
|
||||
|
||||
import qualified Data.ByteString.Lazy.Char8 as LZ
|
||||
-- HTTP request and JSON handling
|
||||
import Network.HTTP.Conduit
|
||||
import Control.Lens.Operators ((^?))
|
||||
import Control.Lens.Aeson
|
||||
import Data.Aeson.Encode (fromValue)
|
||||
import qualified Data.Text.Lazy as TLZ
|
||||
import qualified Data.Text.Lazy.Builder as TLB
|
||||
|
||||
-- | make a simple http request but add a user agent to the HTTP header
|
||||
simpleHTTPWithUserAgent :: String -> IO LZ.ByteString
|
||||
simpleHTTPWithUserAgent url = do
|
||||
r <- parseUrl url
|
||||
let request = r { requestHeaders = [ ("User-Agent","HTTP-Conduit") ] }
|
||||
body <- withManager $ \manager -> do
|
||||
response <- httpLbs request manager
|
||||
return $ responseBody response
|
||||
return body
|
||||
|
||||
-- | Ask the github API
|
||||
-- A strange behaviour you HAVE TO add a User-Agent in your header.
|
||||
-- It took me way too long to get this error
|
||||
searchGHUserFromEmail :: String -> IO (Maybe String)
|
||||
searchGHUserFromEmail "" = return Nothing
|
||||
searchGHUserFromEmail email = do
|
||||
let url = "https://api.github.com/search/users?q=" ++ email
|
||||
body <- simpleHTTPWithUserAgent url
|
||||
login <- return $ body ^? key "items" . nth 0 . key "login"
|
||||
return $ fmap jsonValueToString login
|
||||
where
|
||||
jsonValueToString = TLZ.unpack . TLB.toLazyText . fromValue
|
42
src/HolyProject/MontyPython.hs
Normal file
42
src/HolyProject/MontyPython.hs
Normal file
|
@ -0,0 +1,42 @@
|
|||
module HolyProject.MontyPython
|
||||
( bk
|
||||
, you
|
||||
, ask
|
||||
)
|
||||
where
|
||||
-- Console read write with colors
|
||||
import System.Console.ANSI
|
||||
import System.IO (hFlush, stdout)
|
||||
import Data.Maybe (fromJust)
|
||||
|
||||
-- | bridgekeeper speak
|
||||
bk :: String -> IO ()
|
||||
bk str = colorPutStr Green ("Bridgekeeper: " ++ str ++ "\n")
|
||||
-- | the user dialog
|
||||
you :: String -> IO ()
|
||||
you str = colorPutStr Yellow ("Sir Yourself: " ++ str ++ "\n")
|
||||
|
||||
-- | show color
|
||||
colorPutStr :: Color -> String -> IO ()
|
||||
colorPutStr color str = do
|
||||
setSGR [ SetColor Foreground Dull color
|
||||
, SetConsoleIntensity NormalIntensity
|
||||
]
|
||||
putStr str
|
||||
setSGR []
|
||||
|
||||
-- | Ask for some info and returns it
|
||||
ask :: String -- ^ What? "name" for example
|
||||
-> Maybe String -- ^ Default value
|
||||
-> IO String
|
||||
ask info hint = do
|
||||
bk $ "What is your " ++ info ++ "?" ++
|
||||
(maybe "" (\h -> " ("++h++")") hint)
|
||||
putStr "> "
|
||||
hFlush stdout
|
||||
answer <- getLine
|
||||
putStrLn ""
|
||||
return $ if (answer == "") && (hint /= Nothing)
|
||||
then fromJust hint
|
||||
else answer
|
||||
|
24
src/HolyProject/StringUtils.hs
Normal file
24
src/HolyProject/StringUtils.hs
Normal file
|
@ -0,0 +1,24 @@
|
|||
module HolyProject.StringUtils where
|
||||
|
||||
-- Project name manipulation
|
||||
import Data.Char (toUpper,toLower,isLetter,isNumber)
|
||||
import Data.List (intersperse)
|
||||
import Data.List.Split (splitOneOf)
|
||||
|
||||
-- | transform a chain like "Holy project" in "holy-project"
|
||||
projectNameFromString :: String -> String
|
||||
projectNameFromString str = concat $ intersperse "-" (splitOneOf " -" (map toLower str))
|
||||
|
||||
-- | transform a chain like "Holy project" in "HolyProject"
|
||||
capitalize :: String -> String
|
||||
capitalize str = concat (map capitalizeWord (splitOneOf " -" str))
|
||||
where
|
||||
capitalizeWord :: String -> String
|
||||
capitalizeWord (x:xs) = (toUpper x):map toLower xs
|
||||
capitalizeWord _ = []
|
||||
|
||||
-- | verify if a project name is conform
|
||||
checkProjectName :: String -> Bool
|
||||
checkProjectName [] = False
|
||||
checkProjectName str = all (\c -> (isLetter c)||(isNumber c)||(c=='-')||(c==' ')) str
|
||||
|
Loading…
Reference in a new issue