1 {-# LANGUAGE TemplateHaskell, DataKinds #-}
    2 module Databrary.Model.ORCID
    3   ( ORCID(..)
    4   , blankORCID
    5   , orcidURL
    6   ) where
    7 
    8 import Control.Monad (guard)
    9 import qualified Data.ByteString.Char8 as BSC
   10 import Data.Char (isDigit, digitToInt, intToDigit)
   11 import Data.List (foldl')
   12 import Database.PostgreSQL.Typed.Types (PGParameter(..), PGColumn(..))
   13 import Instances.TH.Lift ()
   14 import Language.Haskell.TH.Lift (deriveLift)
   15 import qualified Network.URI as URI
   16 import qualified Text.ParserCombinators.ReadP as RP
   17 import qualified Text.ParserCombinators.ReadPrec as RP (lift)
   18 import Text.Read (Read(readPrec))
   19 
   20 newtype ORCID = ORCID { orcid :: BSC.ByteString } -- deriving (Eq)
   21 
   22 instance PGParameter "bpchar" ORCID where
   23   pgEncode t = pgEncode t . orcid
   24   pgEncodeValue e t = pgEncodeValue e t . orcid
   25   pgLiteral t = pgLiteral t . orcid
   26 instance PGColumn "bpchar" ORCID where
   27   pgDecode t = ORCID . pgDecode t
   28   pgDecodeValue e t = ORCID . pgDecodeValue e t
   29 instance PGColumn "character varying" ORCID where
   30   pgDecode t = ORCID . pgDecode t
   31   pgDecodeValue e t = ORCID . pgDecodeValue e t
   32 
   33 
   34 deriveLift ''ORCID
   35 
   36 checksumDigit :: Int -> Char
   37 checksumDigit 10 = 'X'
   38 checksumDigit i = intToDigit i
   39 
   40 instance Show ORCID where
   41   show (ORCID s) = group $ BSC.unpack s where
   42     group (a:b:c:d:r@(_:_)) = a:b:c:d:'-':group r
   43     group r = r
   44 
   45 instance Read ORCID where
   46   readPrec = RP.lift $ do
   47     RP.skipSpaces
   48     RP.optional $ RP.string "http://"
   49     RP.optional $ RP.string "orcid.org/"
   50     b <- RP.count 15 $ do
   51       RP.optional $ RP.char '-'
   52       RP.satisfy isDigit
   53     RP.optional $ RP.char '-'
   54     c <- RP.satisfy (\c -> 'X' == c || isDigit c)
   55     guard $ checksumDigit (10 - (9 + foldl' (\s -> (*) 2 . (+) s . digitToInt) 0 b) `mod` 11) == c
   56     return $ ORCID $ BSC.snoc (BSC.pack b) c
   57 
   58 blankORCID :: ORCID
   59 blankORCID = ORCID BSC.empty -- "0000000000000001"
   60 
   61 orcidURL :: ORCID -> URI.URI
   62 orcidURL o = URI.nullURI
   63   { URI.uriScheme = "http:"
   64   , URI.uriAuthority = Just URI.URIAuth
   65     { URI.uriUserInfo = ""
   66     , URI.uriRegName = "orcid.org"
   67     , URI.uriPort = ""
   68     }
   69   , URI.uriPath = '/' : show o
   70   }