{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Defaults
( getDefaults,
Defaults (..),
dName,
dHomePage,
dCabalName,
isValidPackageName,
)
where
import Control.Applicative ((<|>))
import Data.Maybe (fromMaybe)
import Data.Text (Text, pack, replace, stripPrefix, unpack)
import Data.Time (LocalTime (localDay), getCurrentTime, getCurrentTimeZone, utcToLocalTime)
import Data.Time.Calendar (Year)
import Data.Time.Calendar.OrdinalDate (toOrdinalDate)
import qualified Git (config)
import Network.URI (URI (uriPath), parseURI)
import System.Directory.Extra (getCurrentDirectory)
import System.FilePath (stripExtension, takeFileName)
import Text.Regex.TDFA ((=~))
data Defaults = Defaults
{ Defaults -> Text
dOrigin :: Text,
Defaults -> Text
dAuthor :: Text,
Defaults -> Text
dMaintainer :: Text,
Defaults -> String
dPath :: FilePath,
Defaults -> Year
dYear :: Year
}
deriving (Int -> Defaults -> ShowS
[Defaults] -> ShowS
Defaults -> String
(Int -> Defaults -> ShowS)
-> (Defaults -> String) -> ([Defaults] -> ShowS) -> Show Defaults
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Defaults -> ShowS
showsPrec :: Int -> Defaults -> ShowS
$cshow :: Defaults -> String
show :: Defaults -> String
$cshowList :: [Defaults] -> ShowS
showList :: [Defaults] -> ShowS
Show, Defaults -> Defaults -> Bool
(Defaults -> Defaults -> Bool)
-> (Defaults -> Defaults -> Bool) -> Eq Defaults
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Defaults -> Defaults -> Bool
== :: Defaults -> Defaults -> Bool
$c/= :: Defaults -> Defaults -> Bool
/= :: Defaults -> Defaults -> Bool
Eq)
dName :: Defaults -> Maybe Text
dName :: Defaults -> Maybe Text
dName = (URI -> Text) -> Maybe URI -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap URI -> Text
toName (Maybe URI -> Maybe Text)
-> (Defaults -> Maybe URI) -> Defaults -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Defaults -> Maybe URI
dHomePage
where
toName :: URI -> Text
toName = String -> Text
pack (String -> Text) -> (URI -> String) -> URI -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
takeFileName ShowS -> (URI -> String) -> URI -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> String
uriPath
dCabalName :: Defaults -> Maybe Text
dCabalName :: Defaults -> Maybe Text
dCabalName Defaults
ds = do
Text
name <- Defaults -> Maybe Text
dName Defaults
ds
if Text -> Bool
isValidPackageName Text
name then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name else Maybe Text
forall a. Maybe a
Nothing
dHomePage :: Defaults -> Maybe URI
dHomePage :: Defaults -> Maybe URI
dHomePage Defaults {Year
String
Text
dOrigin :: Defaults -> Text
dAuthor :: Defaults -> Text
dMaintainer :: Defaults -> Text
dPath :: Defaults -> String
dYear :: Defaults -> Year
dOrigin :: Text
dAuthor :: Text
dMaintainer :: Text
dPath :: String
dYear :: Year
..} =
String -> URI -> URI
stripURIExtension String
"git"
(URI -> URI) -> Maybe URI -> Maybe URI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( Text -> Maybe URI
toURI Text
dOrigin
Maybe URI -> Maybe URI -> Maybe URI
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> Maybe URI
toURI (Text -> Maybe URI) -> Maybe Text -> Maybe URI
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Maybe Text
sshToHttp Text
dOrigin)
)
where
sshToHttp :: Text -> Maybe Text
sshToHttp = (Text -> Text) -> Maybe Text -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text
"http://" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
replace Text
":" Text
"/") (Maybe Text -> Maybe Text)
-> (Text -> Maybe Text) -> Text -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Maybe Text
stripPrefix Text
"git@"
toURI :: Text -> Maybe URI
toURI = String -> Maybe URI
parseURI (String -> Maybe URI) -> (Text -> String) -> Text -> Maybe URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack
stripURIExtension :: String -> URI -> URI
stripURIExtension String
ext URI
uri =
let p :: String
p = URI -> String
uriPath URI
uri
in URI
uri {uriPath = fromMaybe p (stripExtension ext p)}
getDefaults :: IO Defaults
getDefaults :: IO Defaults
getDefaults = do
Text
dOrigin <- Text -> IO Text
Git.config Text
"remote.origin.url"
Text
dAuthor <- Text -> IO Text
Git.config Text
"user.name"
Text
dMaintainer <- Text -> IO Text
Git.config Text
"user.email"
String
dPath <- IO String
getCurrentDirectory
TimeZone
timezone <- IO TimeZone
getCurrentTimeZone
(Year
dYear, Int
_day) <- Day -> (Year, Int)
toOrdinalDate (Day -> (Year, Int)) -> (UTCTime -> Day) -> UTCTime -> (Year, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalTime -> Day
localDay (LocalTime -> Day) -> (UTCTime -> LocalTime) -> UTCTime -> Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeZone -> UTCTime -> LocalTime
utcToLocalTime TimeZone
timezone (UTCTime -> (Year, Int)) -> IO UTCTime -> IO (Year, Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
Defaults -> IO Defaults
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Defaults {Year
String
Text
dOrigin :: Text
dAuthor :: Text
dMaintainer :: Text
dPath :: String
dYear :: Year
dOrigin :: Text
dAuthor :: Text
dMaintainer :: Text
dPath :: String
dYear :: Year
..}
isValidPackageName :: Text -> Bool
isValidPackageName :: Text -> Bool
isValidPackageName = (Text -> String -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target) =>
source1 -> source -> target
=~ (String
"^[[:digit:]]*[[:alpha:]][[:alnum:]]*(-[[:digit:]]*[[:alpha:]][[:alnum:]]*)*$" :: String))