Merge pull request #11 from Archaeology-ABM/orcidValidation

ORCID validation

CHANGELOG.md

@@ -1,3 +1,4 @@
+- V 0.8.0: Added validation of the ORCID identifier
 - V 0.7.0: Adapted checks on softwareDependencies to nassa-schema v0.3.0
 - V 0.6.1: Discarded checks on designDetailsFile field
 - V 0.6.0: Added all the necessary mechanisms to make nassa aware of the NASSA standard versions of modules

nassa.cabal

@@ -1,5 +1,5 @@
 name:                nassa
-version:             0.7.0
+version:             0.8.0
 synopsis:            A package to validate NASSA modules
 description:         NASSA maintains a library of agent-based-modelling algorithms in individual code modules. Each module is defined by a NASSA.yml file. nassa-hs validates these .yml files.
 license:             MIT

src/NASSA/Types.hs

@@ -4,18 +4,20 @@
 module NASSA.Types where
 
 import           Control.Applicative        ((<|>))
-import           Control.Monad              (mzero)
+import           Control.Monad              (mzero, guard)
 import           Data.Aeson                 (FromJSON,
                                              parseJSON, withObject,
-                                             (.:), (.:?), withText, 
-                                             Value (String))
+                                             (.:), (.:?), withText,
+                                             Value (String), ToJSON (..))
 import qualified Data.Text                  as T
 import qualified Data.Text.Encoding         as TS
 import           Data.Time                  (Day)
 import           Data.Version               (Version, makeVersion, showVersion)
 import qualified Text.Parsec                as P
 import qualified Text.Parsec.Text           as P
 import qualified Text.Email.Validate        as TEV
+import Data.Char (digitToInt)
+import Data.List (intercalate)
 
 newtype NassaModule = NassaModule (FilePath, NassaModuleYamlStruct)
     deriving (Show, Eq)
@@ -171,8 +173,10 @@ instance FromJSON Email where
         Just x  -> pure $ Email x
     parseJSON _ = mzero
 
+-- | 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
-    { _orcidNums :: [Char]
+    { _orcidNums     :: [Char]
     , _orcidChecksum :: Char
     }
     deriving (Show, Eq)
@@ -183,19 +187,47 @@ instance FromJSON ORCID where
         Right x  -> pure x
     parseJSON _          = mzero
 
+instance ToJSON ORCID where
+    toJSON x = String $ T.pack $ renderORCID x
+
 parseORCID :: P.Parser ORCID
 parseORCID = do
-  (\a b c d e -> ORCID (concat [a,b,c,d]) e) <$>
-        fourBlock <* m
-    <*> fourBlock <* m
-    <*> fourBlock <* m
-    <*> threeBlock <*> checksumDigit <* P.eof
+    orcid <- (\a b c d e -> ORCID (concat [a,b,c,d]) e) <$>
+            fourBlock <* m
+        <*> fourBlock <* m
+        <*> fourBlock <* m
+        <*> threeBlock <*> checksumDigit <* P.eof
+    guard (validateORCID orcid) P.<?> "ORCID is not valid"
+    return orcid
   where
       fourBlock = P.count 4 P.digit
       m = P.oneOf "-"
       threeBlock = P.count 3 P.digit
       checksumDigit = P.digit P.<|> P.char 'X'
 
+validateORCID :: ORCID -> Bool
+validateORCID (ORCID nums check) =
+    let numsInt = map digitToInt nums
+        total = makeTotal 0 numsInt
+        remainder = total `mod` 11
+        result = (12 - remainder) `mod` 11
+        checkInt = if check == 'X' then 10 else digitToInt check
+    in result == checkInt
+    where
+        makeTotal :: Int -> [Int] -> Int
+        makeTotal a []     = a
+        makeTotal a (x:xs) = makeTotal ((a + x) * 2) xs
+
+renderORCID :: ORCID -> String
+renderORCID (ORCID nums check) =
+    intercalate "-" (chunks 4 nums) ++ [check]
+    where
+        chunks :: Int -> [a] -> [[a]]
+        chunks _ [] = []
+        chunks n xs =
+            let (ys, zs) = splitAt n xs
+            in  ys : chunks n zs
+
 data ReferenceStruct = ReferenceStruct
     { _referencesBibFile :: FilePath
     , _referencesModuleReferences :: Maybe [String]