module Security.Advisories.Core.HsecId
  (
    HsecId
  , hsecIdYear
  , hsecIdSerial
  , mkHsecId
  , placeholder
  , isPlaceholder
  , parseHsecId
  , printHsecId
  , nextHsecId
  , getNextHsecId
  ) where

import Control.Monad (guard, join)

import Data.Time (getCurrentTime, utctDay)
import Data.Time.Calendar.OrdinalDate (toOrdinalDate)

import Safe (readMay)

data HsecId = HsecId Integer Integer
  deriving (HsecId -> HsecId -> Bool
(HsecId -> HsecId -> Bool)
-> (HsecId -> HsecId -> Bool) -> Eq HsecId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HsecId -> HsecId -> Bool
== :: HsecId -> HsecId -> Bool
$c/= :: HsecId -> HsecId -> Bool
/= :: HsecId -> HsecId -> Bool
Eq, Eq HsecId
Eq HsecId =>
(HsecId -> HsecId -> Ordering)
-> (HsecId -> HsecId -> Bool)
-> (HsecId -> HsecId -> Bool)
-> (HsecId -> HsecId -> Bool)
-> (HsecId -> HsecId -> Bool)
-> (HsecId -> HsecId -> HsecId)
-> (HsecId -> HsecId -> HsecId)
-> Ord HsecId
HsecId -> HsecId -> Bool
HsecId -> HsecId -> Ordering
HsecId -> HsecId -> HsecId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: HsecId -> HsecId -> Ordering
compare :: HsecId -> HsecId -> Ordering
$c< :: HsecId -> HsecId -> Bool
< :: HsecId -> HsecId -> Bool
$c<= :: HsecId -> HsecId -> Bool
<= :: HsecId -> HsecId -> Bool
$c> :: HsecId -> HsecId -> Bool
> :: HsecId -> HsecId -> Bool
$c>= :: HsecId -> HsecId -> Bool
>= :: HsecId -> HsecId -> Bool
$cmax :: HsecId -> HsecId -> HsecId
max :: HsecId -> HsecId -> HsecId
$cmin :: HsecId -> HsecId -> HsecId
min :: HsecId -> HsecId -> HsecId
Ord)

instance Show HsecId where
  show :: HsecId -> String
show = HsecId -> String
printHsecId

-- | Make an 'HsecId'.  Year and serial must both be positive, or
-- else both must be zero (the 'placeholder').
mkHsecId
  :: Integer -- ^ Year
  -> Integer -- ^ Serial number within year
  -> Maybe HsecId
mkHsecId :: Integer -> Integer -> Maybe HsecId
mkHsecId Integer
y Integer
n
  | Integer
y Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 Bool -> Bool -> Bool
&& Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 Bool -> Bool -> Bool
|| Integer
y Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 Bool -> Bool -> Bool
&& Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 = HsecId -> Maybe HsecId
forall a. a -> Maybe a
Just (HsecId -> Maybe HsecId) -> HsecId -> Maybe HsecId
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> HsecId
HsecId Integer
y Integer
n
  | Bool
otherwise = Maybe HsecId
forall a. Maybe a
Nothing

hsecIdYear :: HsecId -> Integer
hsecIdYear :: HsecId -> Integer
hsecIdYear (HsecId Integer
y Integer
_) = Integer
y

hsecIdSerial :: HsecId -> Integer
hsecIdSerial :: HsecId -> Integer
hsecIdSerial (HsecId Integer
_ Integer
n) = Integer
n

-- | The placeholder ID: __HSEC-0000-0000__.
-- See also 'isPlaceholder'.
placeholder :: HsecId
placeholder :: HsecId
placeholder = Integer -> Integer -> HsecId
HsecId Integer
0 Integer
0

-- | Test whether an ID is the 'placeholder'
isPlaceholder :: HsecId -> Bool
isPlaceholder :: HsecId -> Bool
isPlaceholder = HsecId -> HsecId -> Bool
forall a. Eq a => a -> a -> Bool
(==) HsecId
placeholder

-- | Parse an 'HsecId'.  The 'placeholder' is accepted.
parseHsecId :: String -> Maybe HsecId
parseHsecId :: String -> Maybe HsecId
parseHsecId String
s = case String
s of
  Char
'H':Char
'S':Char
'E':Char
'C':Char
'-':String
t ->
    let
      (String
y, String
t') = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-') String
t
      n :: String
n = Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 String
t'
    in do
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
4  -- year must have at least 4 digits
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
4  -- serial must have at least 4 digits
      Maybe (Maybe HsecId) -> Maybe HsecId
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe HsecId) -> Maybe HsecId)
-> Maybe (Maybe HsecId) -> Maybe HsecId
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Maybe HsecId
mkHsecId (Integer -> Integer -> Maybe HsecId)
-> Maybe Integer -> Maybe (Integer -> Maybe HsecId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe Integer
forall a. Read a => String -> Maybe a
readMay String
y Maybe (Integer -> Maybe HsecId)
-> Maybe Integer -> Maybe (Maybe HsecId)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Maybe Integer
forall a. Read a => String -> Maybe a
readMay String
n
  String
_ -> Maybe HsecId
forall a. Maybe a
Nothing

printHsecId :: HsecId -> String
printHsecId :: HsecId -> String
printHsecId (HsecId Integer
y Integer
n) = String
"HSEC-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
pad (Integer -> String
forall a. Show a => a -> String
show Integer
y) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
pad (Integer -> String
forall a. Show a => a -> String
show Integer
n)
  where
  pad :: ShowS
pad String
s = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Char
'0' String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s

-- | Given a year and an HSEC ID, return a larger HSEC ID.  This
-- function, when given the current year and the greatest allocated
-- HSEC ID, returns the next HSEC ID to allocate.
--
nextHsecId
  :: Integer -- ^ Current year
  -> HsecId
  -> HsecId
nextHsecId :: Integer -> HsecId -> HsecId
nextHsecId Integer
curYear (HsecId Integer
idYear Integer
n)
  | Integer
curYear Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
idYear = Integer -> Integer -> HsecId
HsecId Integer
curYear Integer
1
  | Bool
otherwise = Integer -> Integer -> HsecId
HsecId Integer
idYear (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)

-- | Get the current time, and return an HSEC ID greater than the
-- given HSEC ID.  The year of the returned HSEC ID is the current
-- year.
--
getNextHsecId
  :: HsecId
  -> IO HsecId
getNextHsecId :: HsecId -> IO HsecId
getNextHsecId HsecId
oldId = do
  UTCTime
t <- IO UTCTime
getCurrentTime
  let (Integer
year, Int
_dayOfYear) = Day -> (Integer, Int)
toOrdinalDate (UTCTime -> Day
utctDay UTCTime
t)
  HsecId -> IO HsecId
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsecId -> IO HsecId) -> HsecId -> IO HsecId
forall a b. (a -> b) -> a -> b
$ Integer -> HsecId -> HsecId
nextHsecId Integer
year HsecId
oldId