From 36398843b76c0458e263bc6ca55f0475af3b1b6c Mon Sep 17 00:00:00 2001 From: "Yann Esposito (Yogsototh)" Date: Tue, 26 Nov 2013 22:45:12 +0100 Subject: [PATCH] modularized --- src/HolyProject.hs | 170 +++------------------------------ src/HolyProject/GitConfig.hs | 65 +++++++++++++ src/HolyProject/GitHubAPI.hs | 34 +++++++ src/HolyProject/MontyPython.hs | 42 ++++++++ src/HolyProject/StringUtils.hs | 24 +++++ 5 files changed, 179 insertions(+), 156 deletions(-) create mode 100644 src/HolyProject/GitConfig.hs create mode 100644 src/HolyProject/GitHubAPI.hs create mode 100644 src/HolyProject/MontyPython.hs create mode 100644 src/HolyProject/StringUtils.hs diff --git a/src/HolyProject.hs b/src/HolyProject.hs index 184d8b3..e28aa4a 100644 --- a/src/HolyProject.hs +++ b/src/HolyProject.hs @@ -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 diff --git a/src/HolyProject/GitConfig.hs b/src/HolyProject/GitConfig.hs new file mode 100644 index 0000000..fda0574 --- /dev/null +++ b/src/HolyProject/GitConfig.hs @@ -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 + diff --git a/src/HolyProject/GitHubAPI.hs b/src/HolyProject/GitHubAPI.hs new file mode 100644 index 0000000..b203736 --- /dev/null +++ b/src/HolyProject/GitHubAPI.hs @@ -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 diff --git a/src/HolyProject/MontyPython.hs b/src/HolyProject/MontyPython.hs new file mode 100644 index 0000000..e5fd05e --- /dev/null +++ b/src/HolyProject/MontyPython.hs @@ -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 + diff --git a/src/HolyProject/StringUtils.hs b/src/HolyProject/StringUtils.hs new file mode 100644 index 0000000..d4218e4 --- /dev/null +++ b/src/HolyProject/StringUtils.hs @@ -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 +