{-# 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
..}

-- TODO move to a validators module
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))