Initial implementation

Passes the spec tests and includes a command-line program.

.gitignore

@@ -0,0 +1 @@
+/dist/

README.md

@@ -0,0 +1,9 @@
+# Fernet Haskell Implementation
+
+[![Build Status](https://travis-ci.org/rvl/fernet.svg?branch=master)](https://travis-ci.org/rvl/fernet) [![Hackage](https://img.shields.io/hackage/v/fernet.svg)](http://hackage.haskell.org/package/fernet)
+
+*Fernet* generates and verifies HMAC-based authentication tokens.
+
+See the [Fernet Spec][spec] for a little more information.
+
+[spec]: https://github.com/fernet/spec/blob/master/Spec.md

cli/FernetMain.hs

@@ -0,0 +1,157 @@
+module Main where
+
+import Options.Applicative
+import Data.Monoid ((<>))
+import Control.Monad (join, unless, when)
+import Data.Time.Clock (NominalDiffTime)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString.Char8 as S8
+import qualified Data.ByteString.Lazy.Char8 as L8
+import qualified Data.ByteArray.Encoding as B (Base(..), convertFromBase)
+import Text.Read (readEither)
+import System.IO
+import Data.Bifunctor (first)
+import System.Posix.IO (handleToFd, stdInput)
+import System.Posix.Terminal (queryTerminal)
+
+import Network.Fernet
+
+main :: IO ()
+main = join . execParser $
+  info (helper <*> parser)
+  (  fullDesc
+  <> header "Fernet Utility"
+  <> progDesc "Encrypts/decrypts Fernet tokens. One token per line of input."
+  )
+  where
+    parser :: Parser (IO ())
+    parser =
+      (fernet
+        <$> (KeyText <$> ( strOption
+              ( long "key"
+                <> short 'k'
+                <> metavar "STRING"
+                <> help "Base64-encoded encryption keys"
+              )) <|>
+              KeyFile <$> ( strOption
+                ( long "key-file"
+                  <> metavar "FILENAME"
+                  <> help "File containing base64-encoded keys"
+                )
+              ))
+        <*> ( optional
+              ( flag' Encrypt
+                ( long "encrypt"
+                  <> short 'e'
+                  <> help "Encrypt input" )
+              <|>
+              flag' Decrypt
+                ( long "decrypt"
+                  <> short 'd'
+                  <> help "Decrypt input" )
+              )
+            )
+        <*> option ttl
+            ( long "ttl"
+            <> metavar "SECONDS"
+            <> help "Token lifetime in seconds (default: 0 -- infinite)"
+            <> value 0
+            )) <|>
+      (genKey <$> ( flag' True
+                    (long "gen-key"
+                    <> short 'g'
+                    <> help "Generate a key from the password on standard input"
+                    )))
+{-
+(PasswordText <$> ( strOption
+              ( long "password"
+                <> short 'p'
+                <> metavar "STRING"
+                <> help "Encrypting/signing password"
+              )) <|>
+              PasswordFile <$> ( strOption
+                ( long "password-file"
+                  <> metavar "FILENAME"
+                  <> help "File containing encryption/signing password"
+                )
+              ))
+-}
+
+genKey :: Bool -> IO ()
+genKey _ = do
+  password <- askPassword
+  k <- generateKeyFromPassword iterations password
+  S8.hPutStrLn stdout (keyToBase64 k)
+
+askPassword ::  IO ByteString
+askPassword = do
+  isatty <- queryTerminal stdInput
+  when isatty $ do
+    hSetEcho stdin False
+    S8.hPutStr stderr "Enter password: "
+    hFlush stdout
+  password <- S8.hGetLine stdin
+  when isatty $ do
+    hSetEcho stdin True
+    S8.hPut stderr "\n"
+  return password
+
+ttl :: ReadM NominalDiffTime
+ttl = eitherReader (fmap fromInteger . readEither)
+
+data Action = Encrypt | Decrypt
+data Keys = KeyText String | KeyFile FilePath
+data Password = PasswordText String | PasswordFile FilePath
+
+fernet :: Keys -> Maybe Action -> NominalDiffTime -> IO ()
+fernet ks ax ttl = do
+  k <- readKeys ks
+  L8.hGetContents stdin >>= mapM_ (processLine k ax ttl) . L8.lines
+
+processLine :: Key -> Maybe Action -> NominalDiffTime -> L8.ByteString -> IO ()
+processLine k ax ttl s = doLine k ax ttl s >>= uncurry L8.hPutStrLn . output
+
+output :: Either String ByteString -> (Handle, L8.ByteString)
+output (Left e)  = (stderr, L8.pack e)
+output (Right s) = (stdout, L8.fromStrict s)
+
+doLine :: Key -> Maybe Action -> NominalDiffTime -> L8.ByteString -> IO (Either String ByteString)
+doLine k (Just Encrypt) _   s = lineEncrypt k s
+doLine k (Just Decrypt) ttl s = lineDecrypt k ttl s
+doLine k Nothing        ttl s = doLine k (Just $ sniff s) ttl s
+
+sniff :: BL.ByteString -> Action
+sniff s | ver >= "gA" && ver <= "gP" = Decrypt
+        | otherwise                  = Encrypt
+  where ver = BL.take 2 s
+
+lineEncrypt :: Key -> L8.ByteString -> IO (Either String ByteString)
+lineEncrypt k s = Right <$> encrypt k (L8.toStrict s)
+
+lineDecrypt :: Key -> NominalDiffTime -> L8.ByteString -> IO (Either String ByteString)
+lineDecrypt k ttl s = first show <$> decrypt k ttl (L8.toStrict s)
+
+readKeys :: Keys -> IO Key
+readKeys (KeyText k) = keyFromString k
+readKeys (KeyFile f) = readFirstLine f >>= \k -> readKeys (KeyText k)
+
+readPassword :: Password -> IO Key
+readPassword (PasswordText p) = generateKeyFromPassword iterations (S8.pack p)
+readPassword (PasswordFile f) = readFirstLine f >>= \p -> readPassword (PasswordText p)
+
+iterations = 100000 :: Int
+
+readFirstLine :: FilePath -> IO String
+readFirstLine f = withFile f ReadMode hGetLine
+
+keyFromString :: String -> IO Key
+keyFromString s = case keyFromBase64 (S8.pack s) of
+                    Right k -> return k
+                    Left e -> fail e
+
+-- | Converts 'Maybe' to 'Either'.
+justRight :: e -> Maybe a -> Either e a
+justRight _ (Just a) = Right a
+justRight e Nothing = Left e

fernet.cabal

@@ -1,25 +1,85 @@
--- Initial fernet.cabal generated by cabal init.  For further 
--- documentation, see http://haskell.org/cabal/users-guide/
-
 name:                fernet
 version:             0.1.0.0
-synopsis:            Fernet generates and verifies HMAC-based authentication tokens.
+synopsis:            Generates and verifies HMAC-based authentication tokens.
 -- description:         
 homepage:            https://github.com/rvl/fernet-hs
 license:             LGPL-3
 license-file:        LICENSE
 author:              Rodney Lorrimar
 maintainer:          [email protected]
--- copyright:           
+copyright:           2017 Rodney Lorrimar
 category:            Network
 build-type:          Simple
-extra-source-files:  ChangeLog.md
+extra-source-files:  README.md, ChangeLog.md
 cabal-version:       >=1.10
+stability:           experimental
+bug-reports:         https://github.com/rvl/fernet/issues
+
+flag cli
+  description: Build the example application
+  default: True
 
 library
-  -- exposed-modules:     
-  -- other-modules:       
-  -- other-extensions:    
+  exposed-modules:     Network.Fernet
+  other-modules:       Network.Fernet.Base64
+                     , Network.Fernet.Crypto
+                     , Network.Fernet.Key
+                     , Network.Fernet.Token
+                     , Network.Fernet.Util
   build-depends:       base >=4.9 && <4.10
+                     , binary               >= 0.8.3.0 && < 0.10
+                     , byteable             >= 0.1.1  && < 0.2
+                     , bytestring           >= 0.10.8 && < 0.11
+                     , cryptonite           >= 0.21   && < 0.23
+                     , memory               >= 0.14.1 && < 0.15
+                     , time                 >= 1.6.0  && < 1.7
   hs-source-dirs:      src
   default-language:    Haskell2010
+  default-extensions:  OverloadedStrings
+                     , RecordWildCards
+
+executable fernet
+  if flag(cli)
+    buildable: True
+  else
+    buildable: False
+
+  hs-source-dirs:      cli
+  main-is:             FernetMain.hs
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  build-depends:       base
+                     , fernet
+                     , bytestring
+                     , optparse-applicative >= 0.12 && < 0.15
+                     , memory
+                     , time
+                     , unix                 >= 2.7.2.1 && < 2.8
+  default-language:    Haskell2010
+  default-extensions:  OverloadedStrings
+
+
+test-suite fernet-test
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      test
+  main-is:             Main.hs
+  other-modules:       Network.Fernet.Tests
+  build-depends:       HUnit
+                     , QuickCheck
+                     , aeson                >= 1.0.2  && < 1.1
+                     , base
+                     , bytestring
+                     , fernet
+                     , memory >= 0.14.1
+                     , tasty
+                     , tasty-golden
+                     , tasty-hunit
+                     , tasty-quickcheck
+                     , time
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  default-language:    Haskell2010
+  default-extensions:  OverloadedStrings
+                     , RecordWildCards
+
+source-repository head
+  type:     git
+  location: https://github.com/rvl/fernet-hs

src/Network/Fernet.hs

@@ -0,0 +1,111 @@
+module Network.Fernet
+  ( encrypt
+  , decrypt
+  , encrypt'
+  , decrypt'
+  , Key
+  , key
+  , generateKey
+  , generateKeyFromPassword
+  , keyFromBase64
+  , keyToBase64
+  , version
+  ) where
+
+import           Data.ByteString        (ByteString)
+import qualified Data.ByteString        as BS
+import           Data.ByteArray         (ScrubbedBytes)
+import           Data.Byteable          (constEqBytes)
+import           Data.Word              (Word8)
+import           Data.Time.Clock        (NominalDiffTime)
+import           Data.Time.Clock.POSIX  (POSIXTime, getPOSIXTime)
+
+import Data.Bifunctor (first)
+
+import Network.Fernet.Crypto
+import Network.Fernet.Key
+import Network.Fernet.Token
+
+version :: Word8
+version = 0x80
+
+----------------------------------------------------------------------------
+-- Encryption
+
+encrypt :: Key -> ByteString -> IO ByteString
+encrypt key text = do
+  ts <- getPOSIXTime
+  iv <- genIV
+  return $ encrypt' key ts iv text
+
+encrypt' :: Key          -- ^ Keys
+         -> POSIXTime    -- ^ Timestamp
+         -> ByteString   -- ^ Initialization Vector
+         -> ByteString   -- ^ Plain text
+         -> ByteString
+encrypt' Key{..} ts iv text =
+  case serialize <$> makeToken encryptionKey ts iv text of
+    Just token -> encode token (sign signingKey token)
+    Nothing -> "" -- this shouldn't happen
+
+makeToken :: ScrubbedBytes     -- ^ Keys
+          -> POSIXTime         -- ^ Timestamp
+          -> ByteString        -- ^ Initialization Vector
+          -> ByteString        -- ^ Plain text
+          -> Maybe TokenFields
+makeToken k ts iv text = TokenFields version ts iv <$> ct
+  where ct = aesEncrypt k iv text
+
+----------------------------------------------------------------------------
+-- Decryption
+
+data DecryptError = TokenMalformed     -- ^ The token could not be decoded into fields.
+                  | TokenInvalid       -- ^ Signature verification failed.
+                  | TokenExpired       -- ^ Token age exceeded given TTL value.
+                  | UnacceptableClockSkew -- ^ Token timestamp is too far in the future.
+                  | KeySizeInvalid     -- ^ The key was not suitable for decryption.
+                  | InvalidBlockSize   -- ^ The ciphertext length was not a multiple of the block size.
+                  | UnsupportedVersion -- ^ The version was not 0x80.
+                  deriving (Show, Eq)
+
+decrypt :: Key -> NominalDiffTime -> ByteString -> IO (Either DecryptError ByteString)
+decrypt key ttl t = do
+  now <- getPOSIXTime
+  return $ decrypt' key ttl now t
+
+decrypt' :: Key -> NominalDiffTime -> POSIXTime -> ByteString -> Either DecryptError ByteString
+decrypt' Key{..} ttl now t = do
+  (fields, tb, sig) <- first (const TokenMalformed) (decode t)
+  checkVersion fields
+  checkTimestamp now fields
+  checkExpiry ttl now fields
+  checkSignature signingKey tb sig
+  checkInputSize fields
+  case aesDecrypt encryptionKey (tfIV fields) (tfCiphertext fields) of
+    Just text -> Right text
+    Nothing -> Left KeySizeInvalid
+
+checkVersion :: TokenFields -> Either DecryptError ()
+checkVersion tf | tfVersion tf == version = Right ()
+                | otherwise = Left UnsupportedVersion
+
+-- | Maximum clock skew in the future direction.
+maxClockSkew :: NominalDiffTime
+maxClockSkew = 60
+
+checkTimestamp :: POSIXTime -> TokenFields -> Either DecryptError ()
+checkTimestamp now TokenFields{..} | tfTimestamp - now <= maxClockSkew = Right ()
+                                   | otherwise = Left UnacceptableClockSkew
+
+checkExpiry :: NominalDiffTime -> POSIXTime -> TokenFields -> Either DecryptError ()
+checkExpiry ttl now TokenFields{..} | now - tfTimestamp < ttl = Right ()
+                                    | otherwise = Left TokenExpired
+
+checkSignature :: ScrubbedBytes -> ByteString -> ByteString -> Either DecryptError ()
+checkSignature k tf sig | constEqBytes sig (sign k tf) = Right ()
+                        | otherwise                    = Left TokenInvalid
+
+checkInputSize :: TokenFields -> Either DecryptError ()
+checkInputSize tf | isBlocked (tfCiphertext tf) = Right ()
+                  | otherwise                   = Left InvalidBlockSize
+  where isBlocked t = BS.length t `mod` cipherBlockSize == 0