{-# LANGUAGE OverloadedStrings #-}

module Poseidon.Contributor (
    ContributorSpec (..),
    contributorSpecParser,
    ORCID (..)
) where

import           Poseidon.Utils     (showParsecErr)

import           Control.Monad      (guard, mzero)
import           Data.Aeson         (FromJSON, ToJSON (..), Value (String),
                                     object, parseJSON, toJSON, withObject,
                                     (.:), (.:?), (.=))
import           Data.Char          (digitToInt)
import           Data.List          (intercalate)
import           Data.Text          (pack, unpack)
import qualified Text.Parsec        as P
import qualified Text.Parsec.String as P


-- | A data type to represent a contributor
data ContributorSpec = ContributorSpec
    { ContributorSpec -> [Char]
contributorName  :: String -- ^ the name of a contributor
    , ContributorSpec -> [Char]
contributorEmail :: String -- ^ the email address of a contributor
    , ContributorSpec -> Maybe ORCID
contributorORCID :: Maybe ORCID -- ^ the ORCID of a contributor
    }
    deriving (Int -> ContributorSpec -> ShowS
[ContributorSpec] -> ShowS
ContributorSpec -> [Char]
(Int -> ContributorSpec -> ShowS)
-> (ContributorSpec -> [Char])
-> ([ContributorSpec] -> ShowS)
-> Show ContributorSpec
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ContributorSpec -> ShowS
showsPrec :: Int -> ContributorSpec -> ShowS
$cshow :: ContributorSpec -> [Char]
show :: ContributorSpec -> [Char]
$cshowList :: [ContributorSpec] -> ShowS
showList :: [ContributorSpec] -> ShowS
Show, ContributorSpec -> ContributorSpec -> Bool
(ContributorSpec -> ContributorSpec -> Bool)
-> (ContributorSpec -> ContributorSpec -> Bool)
-> Eq ContributorSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ContributorSpec -> ContributorSpec -> Bool
== :: ContributorSpec -> ContributorSpec -> Bool
$c/= :: ContributorSpec -> ContributorSpec -> Bool
/= :: ContributorSpec -> ContributorSpec -> Bool
Eq)

-- | To facilitate automatic parsing of ContributorSpec from JSON files
instance FromJSON ContributorSpec where
    parseJSON :: Value -> Parser ContributorSpec
parseJSON = [Char]
-> (Object -> Parser ContributorSpec)
-> Value
-> Parser ContributorSpec
forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"contributor" ((Object -> Parser ContributorSpec)
 -> Value -> Parser ContributorSpec)
-> (Object -> Parser ContributorSpec)
-> Value
-> Parser ContributorSpec
forall a b. (a -> b) -> a -> b
$ \Object
v -> [Char] -> [Char] -> Maybe ORCID -> ContributorSpec
ContributorSpec
        ([Char] -> [Char] -> Maybe ORCID -> ContributorSpec)
-> Parser [Char]
-> Parser ([Char] -> Maybe ORCID -> ContributorSpec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser [Char]
forall a. FromJSON a => Object -> Key -> Parser a
.:  Key
"name"
        Parser ([Char] -> Maybe ORCID -> ContributorSpec)
-> Parser [Char] -> Parser (Maybe ORCID -> ContributorSpec)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser [Char]
forall a. FromJSON a => Object -> Key -> Parser a
.:  Key
"email"
        Parser (Maybe ORCID -> ContributorSpec)
-> Parser (Maybe ORCID) -> Parser ContributorSpec
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe ORCID)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"orcid"

instance ToJSON ContributorSpec where
    -- this encodes directly to a bytestring Builder
    toJSON :: ContributorSpec -> Value
toJSON ContributorSpec
x = [Pair] -> Value
object [
          Key
"name"  Key -> [Char] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ContributorSpec -> [Char]
contributorName ContributorSpec
x
        , Key
"email" Key -> [Char] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ContributorSpec -> [Char]
contributorEmail ContributorSpec
x
        , Key
"orcid" Key -> Maybe ORCID -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ContributorSpec -> Maybe ORCID
contributorORCID ContributorSpec
x
        ]

contributorSpecParser :: P.Parser [ContributorSpec]
contributorSpecParser :: Parser [ContributorSpec]
contributorSpecParser = Parser [ContributorSpec] -> Parser [ContributorSpec]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try (ParsecT [Char] () Identity ContributorSpec
-> ParsecT [Char] () Identity Char -> Parser [ContributorSpec]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
P.sepBy ParsecT [Char] () Identity ContributorSpec
oneContributorSpecParser (Char -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
';' ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity () -> ParsecT [Char] () Identity Char
forall a b.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity b -> ParsecT [Char] () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT [Char] () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
P.spaces))

oneContributorSpecParser :: P.Parser ContributorSpec
oneContributorSpecParser :: ParsecT [Char] () Identity ContributorSpec
oneContributorSpecParser = do
    [Char]
name <- ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity [Char]
-> ParsecT [Char] () Identity [Char]
forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
P.between (Char -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'[') (Char -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
']') (ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity [Char]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
P.manyTill ParsecT [Char] () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.anyChar (ParsecT [Char] () Identity Char -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
P.lookAhead (Char -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
']')))
    [Char]
email <- ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity [Char]
-> ParsecT [Char] () Identity [Char]
forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
P.between (Char -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'(') (Char -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
')') (ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity [Char]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
P.manyTill ParsecT [Char] () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.anyChar (ParsecT [Char] () Identity Char -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
P.lookAhead (Char -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
')')))
    -- TODO: add option to add ORCID here
    ContributorSpec -> ParsecT [Char] () Identity ContributorSpec
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> [Char] -> Maybe ORCID -> ContributorSpec
ContributorSpec [Char]
name [Char]
email Maybe ORCID
forall a. Maybe a
Nothing)

-- | A data type to represent an ORCID
-- see https://support.orcid.org/hc/en-us/articles/360006897674-Structure-of-the-ORCID-Identifier
data ORCID = ORCID
    { ORCID -> [Char]
_orcidNums     :: [Char]
    , ORCID -> Char
_orcidChecksum :: Char
    }
    deriving (Int -> ORCID -> ShowS
[ORCID] -> ShowS
ORCID -> [Char]
(Int -> ORCID -> ShowS)
-> (ORCID -> [Char]) -> ([ORCID] -> ShowS) -> Show ORCID
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ORCID -> ShowS
showsPrec :: Int -> ORCID -> ShowS
$cshow :: ORCID -> [Char]
show :: ORCID -> [Char]
$cshowList :: [ORCID] -> ShowS
showList :: [ORCID] -> ShowS
Show, ORCID -> ORCID -> Bool
(ORCID -> ORCID -> Bool) -> (ORCID -> ORCID -> Bool) -> Eq ORCID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ORCID -> ORCID -> Bool
== :: ORCID -> ORCID -> Bool
$c/= :: ORCID -> ORCID -> Bool
/= :: ORCID -> ORCID -> Bool
Eq)

instance FromJSON ORCID where
    parseJSON :: Value -> Parser ORCID
parseJSON (String Text
s) = case Parsec [Char] () ORCID
-> () -> [Char] -> [Char] -> Either ParseError ORCID
forall s t u a.
Stream s Identity t =>
Parsec s u a -> u -> [Char] -> s -> Either ParseError a
P.runParser Parsec [Char] () ORCID
parseORCID () [Char]
"" (Text -> [Char]
unpack Text
s) of
        Left ParseError
err -> [Char] -> Parser ORCID
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser ORCID) -> [Char] -> Parser ORCID
forall a b. (a -> b) -> a -> b
$ ParseError -> [Char]
showParsecErr ParseError
err
        Right ORCID
x  -> ORCID -> Parser ORCID
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ORCID
x
    parseJSON Value
_          = Parser ORCID
forall a. Parser a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

instance ToJSON ORCID where
    toJSON :: ORCID -> Value
toJSON ORCID
x = Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ ORCID -> [Char]
renderORCID ORCID
x

parseORCID :: P.Parser ORCID
parseORCID :: Parsec [Char] () ORCID
parseORCID = do
    ORCID
orcid <- (\[Char]
a [Char]
b [Char]
c [Char]
d Char
e -> [Char] -> Char -> ORCID
ORCID ([[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
a,[Char]
b,[Char]
c,[Char]
d]) Char
e) ([Char] -> [Char] -> [Char] -> [Char] -> Char -> ORCID)
-> ParsecT [Char] () Identity [Char]
-> ParsecT
     [Char] () Identity ([Char] -> [Char] -> [Char] -> Char -> ORCID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            ParsecT [Char] () Identity [Char]
forall {u}. ParsecT [Char] u Identity [Char]
fourBlock ParsecT
  [Char] () Identity ([Char] -> [Char] -> [Char] -> Char -> ORCID)
-> ParsecT [Char] () Identity Char
-> ParsecT
     [Char] () Identity ([Char] -> [Char] -> [Char] -> Char -> ORCID)
forall a b.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity b -> ParsecT [Char] () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT [Char] () Identity Char
forall {u}. ParsecT [Char] u Identity Char
m
        ParsecT
  [Char] () Identity ([Char] -> [Char] -> [Char] -> Char -> ORCID)
-> ParsecT [Char] () Identity [Char]
-> ParsecT [Char] () Identity ([Char] -> [Char] -> Char -> ORCID)
forall a b.
ParsecT [Char] () Identity (a -> b)
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT [Char] () Identity [Char]
forall {u}. ParsecT [Char] u Identity [Char]
fourBlock ParsecT [Char] () Identity ([Char] -> [Char] -> Char -> ORCID)
-> ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity ([Char] -> [Char] -> Char -> ORCID)
forall a b.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity b -> ParsecT [Char] () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT [Char] () Identity Char
forall {u}. ParsecT [Char] u Identity Char
m
        ParsecT [Char] () Identity ([Char] -> [Char] -> Char -> ORCID)
-> ParsecT [Char] () Identity [Char]
-> ParsecT [Char] () Identity ([Char] -> Char -> ORCID)
forall a b.
ParsecT [Char] () Identity (a -> b)
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT [Char] () Identity [Char]
forall {u}. ParsecT [Char] u Identity [Char]
fourBlock ParsecT [Char] () Identity ([Char] -> Char -> ORCID)
-> ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity ([Char] -> Char -> ORCID)
forall a b.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity b -> ParsecT [Char] () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT [Char] () Identity Char
forall {u}. ParsecT [Char] u Identity Char
m
        ParsecT [Char] () Identity ([Char] -> Char -> ORCID)
-> ParsecT [Char] () Identity [Char]
-> ParsecT [Char] () Identity (Char -> ORCID)
forall a b.
ParsecT [Char] () Identity (a -> b)
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT [Char] () Identity [Char]
forall {u}. ParsecT [Char] u Identity [Char]
threeBlock ParsecT [Char] () Identity (Char -> ORCID)
-> ParsecT [Char] () Identity Char -> Parsec [Char] () ORCID
forall a b.
ParsecT [Char] () Identity (a -> b)
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT [Char] () Identity Char
forall {u}. ParsecT [Char] u Identity Char
checksumDigit Parsec [Char] () ORCID
-> ParsecT [Char] () Identity () -> Parsec [Char] () ORCID
forall a b.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity b -> ParsecT [Char] () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT [Char] () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
P.eof
    Bool -> ParsecT [Char] () Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ORCID -> Bool
validateORCID ORCID
orcid) ParsecT [Char] () Identity ()
-> [Char] -> ParsecT [Char] () Identity ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
P.<?> [Char]
"ORCID is not valid"
    ORCID -> Parsec [Char] () ORCID
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ORCID
orcid
  where
      fourBlock :: ParsecT [Char] u Identity [Char]
fourBlock = Int
-> ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
Int -> ParsecT s u m a -> ParsecT s u m [a]
P.count Int
4 ParsecT [Char] u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.digit
      m :: ParsecT [Char] u Identity Char
m = [Char] -> ParsecT [Char] u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
P.oneOf [Char]
"-"
      threeBlock :: ParsecT [Char] u Identity [Char]
threeBlock = Int
-> ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
Int -> ParsecT s u m a -> ParsecT s u m [a]
P.count Int
3 ParsecT [Char] u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.digit
      checksumDigit :: ParsecT [Char] u Identity Char
checksumDigit = ParsecT [Char] u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.digit ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity Char -> ParsecT [Char] u Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
P.<|> Char -> ParsecT [Char] u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'X'

validateORCID :: ORCID -> Bool
validateORCID :: ORCID -> Bool
validateORCID (ORCID [Char]
nums Char
check) =
    let numsInt :: [Int]
numsInt = (Char -> Int) -> [Char] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Int
digitToInt [Char]
nums
        total :: Int
total = Int -> [Int] -> Int
makeTotal Int
0 [Int]
numsInt
        remainder :: Int
remainder = Int
total Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
11
        result :: Int
result = (Int
12 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
remainder) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
11
        checkInt :: Int
checkInt = if Char
check Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'X' then Int
10 else Char -> Int
digitToInt Char
check
    in Int
result Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
checkInt
    where
        makeTotal :: Int -> [Int] -> Int
        makeTotal :: Int -> [Int] -> Int
makeTotal Int
a []     = Int
a
        makeTotal Int
a (Int
x:[Int]
xs) = Int -> [Int] -> Int
makeTotal ((Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) [Int]
xs

renderORCID :: ORCID -> String
renderORCID :: ORCID -> [Char]
renderORCID (ORCID [Char]
nums Char
check) =
    [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"-" (Int -> [Char] -> [[Char]]
forall a. Int -> [a] -> [[a]]
chunks Int
4 [Char]
nums) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
check]
    where
        chunks :: Int -> [a] -> [[a]]
        chunks :: forall a. Int -> [a] -> [[a]]
chunks Int
_ [] = []
        chunks Int
n [a]
xs =
            let ([a]
ys, [a]
zs) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
xs
            in  [a]
ys [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
chunks Int
n [a]
zs