diff --git a/ChangeLog.md b/ChangeLog.md
new file mode 100644
--- /dev/null
+++ b/ChangeLog.md
@@ -0,0 +1,5 @@
+# Revision history for fernet
+
+## 0.1.0.0 -- 2017-03-22
+
+* First version. Released on an unsuspecting world.
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,165 @@
+ GNU LESSER GENERAL PUBLIC LICENSE
+ Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc.
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+
+ This version of the GNU Lesser General Public License incorporates
+the terms and conditions of version 3 of the GNU General Public
+License, supplemented by the additional permissions listed below.
+
+ 0. Additional Definitions.
+
+ As used herein, "this License" refers to version 3 of the GNU Lesser
+General Public License, and the "GNU GPL" refers to version 3 of the GNU
+General Public License.
+
+ "The Library" refers to a covered work governed by this License,
+other than an Application or a Combined Work as defined below.
+
+ An "Application" is any work that makes use of an interface provided
+by the Library, but which is not otherwise based on the Library.
+Defining a subclass of a class defined by the Library is deemed a mode
+of using an interface provided by the Library.
+
+ A "Combined Work" is a work produced by combining or linking an
+Application with the Library. The particular version of the Library
+with which the Combined Work was made is also called the "Linked
+Version".
+
+ The "Minimal Corresponding Source" for a Combined Work means the
+Corresponding Source for the Combined Work, excluding any source code
+for portions of the Combined Work that, considered in isolation, are
+based on the Application, and not on the Linked Version.
+
+ The "Corresponding Application Code" for a Combined Work means the
+object code and/or source code for the Application, including any data
+and utility programs needed for reproducing the Combined Work from the
+Application, but excluding the System Libraries of the Combined Work.
+
+ 1. Exception to Section 3 of the GNU GPL.
+
+ You may convey a covered work under sections 3 and 4 of this License
+without being bound by section 3 of the GNU GPL.
+
+ 2. Conveying Modified Versions.
+
+ If you modify a copy of the Library, and, in your modifications, a
+facility refers to a function or data to be supplied by an Application
+that uses the facility (other than as an argument passed when the
+facility is invoked), then you may convey a copy of the modified
+version:
+
+ a) under this License, provided that you make a good faith effort to
+ ensure that, in the event an Application does not supply the
+ function or data, the facility still operates, and performs
+ whatever part of its purpose remains meaningful, or
+
+ b) under the GNU GPL, with none of the additional permissions of
+ this License applicable to that copy.
+
+ 3. Object Code Incorporating Material from Library Header Files.
+
+ The object code form of an Application may incorporate material from
+a header file that is part of the Library. You may convey such object
+code under terms of your choice, provided that, if the incorporated
+material is not limited to numerical parameters, data structure
+layouts and accessors, or small macros, inline functions and templates
+(ten or fewer lines in length), you do both of the following:
+
+ a) Give prominent notice with each copy of the object code that the
+ Library is used in it and that the Library and its use are
+ covered by this License.
+
+ b) Accompany the object code with a copy of the GNU GPL and this license
+ document.
+
+ 4. Combined Works.
+
+ You may convey a Combined Work under terms of your choice that,
+taken together, effectively do not restrict modification of the
+portions of the Library contained in the Combined Work and reverse
+engineering for debugging such modifications, if you also do each of
+the following:
+
+ a) Give prominent notice with each copy of the Combined Work that
+ the Library is used in it and that the Library and its use are
+ covered by this License.
+
+ b) Accompany the Combined Work with a copy of the GNU GPL and this license
+ document.
+
+ c) For a Combined Work that displays copyright notices during
+ execution, include the copyright notice for the Library among
+ these notices, as well as a reference directing the user to the
+ copies of the GNU GPL and this license document.
+
+ d) Do one of the following:
+
+ 0) Convey the Minimal Corresponding Source under the terms of this
+ License, and the Corresponding Application Code in a form
+ suitable for, and under terms that permit, the user to
+ recombine or relink the Application with a modified version of
+ the Linked Version to produce a modified Combined Work, in the
+ manner specified by section 6 of the GNU GPL for conveying
+ Corresponding Source.
+
+ 1) Use a suitable shared library mechanism for linking with the
+ Library. A suitable mechanism is one that (a) uses at run time
+ a copy of the Library already present on the user's computer
+ system, and (b) will operate properly with a modified version
+ of the Library that is interface-compatible with the Linked
+ Version.
+
+ e) Provide Installation Information, but only if you would otherwise
+ be required to provide such information under section 6 of the
+ GNU GPL, and only to the extent that such information is
+ necessary to install and execute a modified version of the
+ Combined Work produced by recombining or relinking the
+ Application with a modified version of the Linked Version. (If
+ you use option 4d0, the Installation Information must accompany
+ the Minimal Corresponding Source and Corresponding Application
+ Code. If you use option 4d1, you must provide the Installation
+ Information in the manner specified by section 6 of the GNU GPL
+ for conveying Corresponding Source.)
+
+ 5. Combined Libraries.
+
+ You may place library facilities that are a work based on the
+Library side by side in a single library together with other library
+facilities that are not Applications and are not covered by this
+License, and convey such a combined library under terms of your
+choice, if you do both of the following:
+
+ a) Accompany the combined library with a copy of the same work based
+ on the Library, uncombined with any other library facilities,
+ conveyed under the terms of this License.
+
+ b) Give prominent notice with the combined library that part of it
+ is a work based on the Library, and explaining where to find the
+ accompanying uncombined form of the same work.
+
+ 6. Revised Versions of the GNU Lesser General Public License.
+
+ The Free Software Foundation may publish revised and/or new versions
+of the GNU Lesser General Public License from time to time. Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns.
+
+ Each version is given a distinguishing version number. If the
+Library as you received it specifies that a certain numbered version
+of the GNU Lesser General Public License "or any later version"
+applies to it, you have the option of following the terms and
+conditions either of that published version or of any later version
+published by the Free Software Foundation. If the Library as you
+received it does not specify a version number of the GNU Lesser
+General Public License, you may choose any version of the GNU Lesser
+General Public License ever published by the Free Software Foundation.
+
+ If the Library as you received it specifies that a proxy can decide
+whether future versions of the GNU Lesser General Public License shall
+apply, that proxy's public statement of acceptance of any version is
+permanent authorization for you to choose that version for the
+Library.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,79 @@
+# Fernet Haskell Implementation
+
+[](https://travis-ci.org/rvl/fernet-hs) [](http://hackage.haskell.org/package/fernet)
+
+*Fernet* generates and verifies HMAC-based authentication tokens.
+
+Originally designed for use within OpenStack clusters, it was intended
+to be fast and light-weight, with non-persistent tokens. Integrity and
+confidentiality of the token contents are implemented with HMAC SHA256
+and AES128 CBC.
+
+See the [Fernet Spec][spec] for a little more information.
+
+[spec]: https://github.com/fernet/spec/blob/master/Spec.md
+
+## Usage
+
+To encrypt a token:
+
+ >>> import Network.Fernet
+ >>> k <- generateKey
+ >>> keyToBase64 k
+ "JQAeL3iFN9wIW_hMKiIzA1EiG_EZNivnMPBOOJn2wZc="
+ >>> token <- encrypt k "secret text"
+ >>> print token
+ "gAAAAABY0H9kx7ihkcj6ZF_bQ73Lvc7aG-ZlEtjx24io-DQy5tCjLbq1JvVY27uAe6BuwG8css-4LDIywOJRyY_zetq7aLPPag=="
+
+The resulting token can be distributed to clients. To check and
+decrypt the token, use the same key:
+
+ >>> decrypt k 60 token
+ Right "secret text"
+
+Do read the [Network.Fernet module][haddock] documentation for further
+information.
+
+[haddock]: http://hackage.haskell.org/package/fernet/docs/Network-Fernet.html
+
+
+## Command-line tool
+
+This package also includes a command-line tool for encrypting and
+decrypting tokens.
+
+ Fernet Utility
+
+ Usage: fernet (((-k|--key STRING) | --key-file FILENAME) ([-e|--encrypt] |
+ [-d|--decrypt]) [--ttl SECONDS] | (-g|--gen-key))
+ Encrypts/decrypts Fernet tokens. One token written to stdout for each line
+ read from stdin. Use --gen-key to make a key.
+
+ Available options:
+ -h,--help Show this help text
+ -k,--key STRING Base64-urlsafe-encoded 32 byte encryption key
+ --key-file FILENAME File containing the encryption key
+ -e,--encrypt Encryption mode (default: autodetect)
+ -d,--decrypt Decryption mode (default: autodetect)
+ --ttl SECONDS Token lifetime in seconds (default: 1 minute)
+ -g,--gen-key Generate a key from the password on standard input
+
+## Development
+
+### Building with Stack
+
+```
+stack build
+```
+
+### Building with Nix
+
+```
+nix-shell -p cabal2nix --command "cabal2nix --shell . > default.nix"
+nix-shell --command "cabal configure"
+cabal build
+```
+
+## Better & Cooler Stuff
+
+You might also be interested in [hsoz](https://github.com/rvl/hsoz).
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/cli/FernetMain.hs b/cli/FernetMain.hs
new file mode 100644
--- /dev/null
+++ b/cli/FernetMain.hs
@@ -0,0 +1,146 @@
+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 written to stdout for each line read from stdin. " ++
+ "Use --gen-key to make a key."
+ ))
+ where
+ parser :: Parser (IO ())
+ parser =
+ (fernet
+ <$> (KeyText <$> ( strOption
+ ( long "key"
+ <> short 'k'
+ <> metavar "STRING"
+ <> help "Base64-urlsafe-encoded 32 byte encryption key"
+ )) <|>
+ KeyFile <$> ( strOption
+ ( long "key-file"
+ <> metavar "FILENAME"
+ <> help "File containing the encryption key"
+ )
+ ))
+ <*> ( optional
+ ( flag' Encrypt
+ ( long "encrypt"
+ <> short 'e'
+ <> help "Encryption mode (default: autodetect)" )
+ <|>
+ flag' Decrypt
+ ( long "decrypt"
+ <> short 'd'
+ <> help "Decryption mode (default: autodetect)" )
+ )
+ )
+ <*> option ttl
+ ( long "ttl"
+ <> metavar "SECONDS"
+ <> help "Token lifetime in seconds (default: 1 minute)"
+ <> value 60
+ )) <|>
+ (genKey <$> ( flag' True
+ (long "gen-key"
+ <> short 'g'
+ <> help "Generate a key from the password on standard input"
+ )))
+
+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) = fst <$> 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
diff --git a/fernet.cabal b/fernet.cabal
new file mode 100644
--- /dev/null
+++ b/fernet.cabal
@@ -0,0 +1,88 @@
+name: fernet
+version: 0.1.0.0
+synopsis: Generate and verify HMAC-based authentication tokens.
+description: Originally designed for use within OpenStack clusters,
+ /Fernet/ is intended to be fast and light-weight, with
+ non-persistent tokens. Fernet tokens are signed with a
+ SHA256 HMAC and their contents encrypted with AES128
+ in CBC mode.
+homepage: https://github.com/rvl/fernet-hs
+license: LGPL-3
+license-file: LICENSE
+author: Rodney Lorrimar
+maintainer: dev@rodney.id.au
+copyright: 2017 Rodney Lorrimar
+category: Web, Authentication
+build-type: Simple
+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: Network.Fernet
+ other-modules: Network.Fernet.Base64
+ , Network.Fernet.Crypto
+ , Network.Fernet.Key
+ , Network.Fernet.Token
+ 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
diff --git a/src/Network/Fernet.hs b/src/Network/Fernet.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Fernet.hs
@@ -0,0 +1,184 @@
+-- | /Fernet/ generates and verifies HMAC-based authentication tokens.
+--
+-- Originally designed for use within OpenStack clusters, it was
+-- intended to be fast and light-weight, with non-persistent
+-- tokens. Integrity and confidentiality of the token contents are
+-- implemented with HMAC SHA256 and AES128 CBC.
+--
+-- See the
+-- for a little more information.
+--
+-- == Usage
+-- To encrypt a token:
+--
+-- >>> import Network.Fernet
+-- >>> k <- generateKey
+-- >>> keyToBase64 k
+-- "JQAeL3iFN9wIW_hMKiIzA1EiG_EZNivnMPBOOJn2wZc="
+-- >>> token <- encrypt k "secret text"
+-- >>> print token
+-- "gAAAAABY0H9kx7ihkcj6ZF_bQ73Lvc7aG-ZlEtjx24io-DQy5tCjLbq1JvVY27uAe6BuwG8css-4LDIywOJRyY_zetq7aLPPag=="
+--
+-- The resulting token can be distributed to clients. To check and
+-- decrypt the token, use the same key:
+--
+-- >>> decrypt k 60 token
+-- Right "secret text"
+--
+-- When decrypting, a TTL value is supplied to determine whether the
+-- token has expired. The timestamp is stored in plain text and can
+-- also be checked with 'hasExpired'.
+--
+-- == Related Modules
+--
+-- * "Network.Iron"
+-- * "Jose.Jwt"
+
+module Network.Fernet
+ ( -- * Tokens
+ encrypt
+ , decrypt
+ , encrypt'
+ , decrypt'
+ , DecryptError(..)
+ , isExpired
+ , hasExpired
+ -- * Keys
+ , Key
+ , key
+ , generateKey
+ , generateKeyFromPassword
+ , keyFromBase64
+ , keyToBase64
+ -- * Other
+ , 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
+
+-- | @0x80@ is the latest token format version, and the only one
+-- supported by this library.
+version :: Word8
+version = 0x80
+
+----------------------------------------------------------------------------
+-- Encryption
+
+-- | Encrypts, encodes, and signs the given token contents with the
+-- given key.
+--
+-- Its timestamp is set to the current time and stored /unencrypted/
+-- in the token.
+encrypt :: Key -- ^ The encryption and signing keys.
+ -> ByteString -- ^ Token contents.
+ -> IO ByteString -- ^ An encoded /Fernet/ token.
+encrypt k text = do
+ ts <- getPOSIXTime
+ iv <- genIV
+ return $ encrypt' k ts iv text
+
+-- | Encrypts, encodes, and signs the given token contents with the
+-- given key.
+--
+-- The provided timestamp is stored /unencrypted/ in the token.
+--
+-- The given IV (initialization vector) string should be a random
+-- sequence of exactly 128 bits.
+encrypt' :: Key -- ^ The encryption and signing keys.
+ -> POSIXTime -- ^ Timestamp
+ -> ByteString -- ^ Initialization Vector.
+ -> ByteString -- ^ Token contents.
+ -> ByteString -- ^ An encoded /Fernet/ token.
+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, unless iv is wrong
+
+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
+
+-- | Some of the reasons why decryption can fail.
+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)
+
+-- | Decodes, checks, and decrypts, the given /Fernet/ token.
+--
+-- If the token's age (determined by its timestamp) exceeds the given
+-- TTL, then this function will fail.
+decrypt :: Key -- ^ The encryption and signing keys.
+ -> NominalDiffTime -- ^ Token TTL.
+ -> ByteString -- ^ The encoded token.
+ -> IO (Either DecryptError ByteString) -- ^ Token contents, or an error.
+decrypt k ttl t = do
+ now <- getPOSIXTime
+ return $ decrypt' k ttl now t
+
+-- | Decodes, checks, and decrypts, the given /Fernet/ token.
+--
+-- If the token's age (determined by its timestamp) exceeds the given
+-- TTL, then this function will fail.
+decrypt' :: Key -- ^ The encryption and signing keys.
+ -> NominalDiffTime -- ^ Token TTL.
+ -> POSIXTime -- ^ The current time, used to determine token age.
+ -> ByteString -- ^ The encoded token.
+ -> Either DecryptError ByteString -- ^ Token contents, or an error.
+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 (tokenIV fields) (tokenCiphertext fields) of
+ Just text -> Right text
+ Nothing -> Left KeySizeInvalid
+
+checkVersion :: TokenFields -> Either DecryptError ()
+checkVersion tf | tokenVersion 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{..} | tokenTimestamp - now <= maxClockSkew = Right ()
+ | otherwise = Left UnacceptableClockSkew
+
+checkExpiry :: NominalDiffTime -> POSIXTime -> TokenFields -> Either DecryptError ()
+checkExpiry ttl now tf | hasExpired' ttl now tf = 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 (tokenCiphertext tf) = Right ()
+ | otherwise = Left InvalidBlockSize
+ where isBlocked t = BS.length t `mod` cipherBlockSize == 0
diff --git a/src/Network/Fernet/Base64.hs b/src/Network/Fernet/Base64.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Fernet/Base64.hs
@@ -0,0 +1,41 @@
+-- | Base64 utilities
+
+module Network.Fernet.Base64 (
+ -- * Base64
+ b64
+ , b64dec
+ , b64url
+ , b64urldec
+ ) where
+
+import Data.Monoid ((<>))
+import qualified Data.ByteString.Char8 as S8
+import Data.ByteArray (ByteArrayAccess)
+import qualified Data.ByteArray.Encoding as B (Base (..), convertToBase, convertFromBase)
+import Data.ByteString (ByteString)
+
+-- | Shorthand for encode in Base64.
+b64 :: ByteArrayAccess a => a -> ByteString
+b64 = B.convertToBase B.Base64
+
+b64url :: ByteArrayAccess a => a -> ByteString
+b64url = urlSafeBase64 . b64
+
+b64dec :: ByteArrayAccess a => a -> Either String ByteString
+b64dec = B.convertFromBase B.Base64
+
+b64urldec :: ByteString -> Either String ByteString
+b64urldec = b64dec . unUrlSafeBase64
+
+-- | Fixes up a Base64 encoded string so that it's more convenient to
+-- include in URLs.
+-- The characters @+@ and @/@ are replaced with @-@ and @_@.
+urlSafeBase64 :: ByteString -> ByteString
+urlSafeBase64 = S8.map (tr '+' '-' . tr '/' '_')
+
+-- | The inverse of 'urlSafeBase64'.
+unUrlSafeBase64 :: ByteString -> ByteString
+unUrlSafeBase64 = S8.map (tr '-' '+' . tr '_' '/')
+
+tr :: Char -> Char -> Char -> Char
+tr a b c = if c == a then b else c
diff --git a/src/Network/Fernet/Crypto.hs b/src/Network/Fernet/Crypto.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Fernet/Crypto.hs
@@ -0,0 +1,59 @@
+module Network.Fernet.Crypto
+ ( sign
+ , aesEncrypt
+ , aesDecrypt
+ , genIV
+ , cipherBlockSize
+ ) where
+
+import Data.ByteString (ByteString)
+import Data.ByteArray (ByteArray, ByteArrayAccess, convert)
+
+import Crypto.Data.Padding (Format(PKCS7), pad, unpad)
+import Crypto.Hash.Algorithms (SHA256 (..))
+import Crypto.Cipher.AES (AES128)
+import Crypto.MAC.HMAC (HMAC(..), hmac, hmacGetDigest)
+import Crypto.Cipher.Types
+import Crypto.Error
+import Crypto.Random (getRandomBytes)
+
+import Network.Fernet.Token (Signature)
+
+sign :: ByteArrayAccess a => a -> ByteString -> Signature
+sign key t = convert $ hmacGetDigest (hmac key t :: HMAC SHA256)
+
+aesEncrypt :: ByteArray a
+ => a -- ^ The encryption key
+ -> ByteString -- ^ Initialization Vector
+ -> ByteString -- ^ Plain text
+ -> Maybe ByteString
+aesEncrypt key iv text = cbcEncrypt <$> ctx <*> iv' <*> text'
+ where
+ ctx = maybeCryptoError (cipherInit key) :: Maybe AES128
+ iv' = makeIV iv
+ p = fmap (PKCS7 . blockSize) ctx
+ text' = pad <$> p <*> pure text
+
+aesDecrypt :: ByteArray a
+ => a -- ^ The encryption key
+ -> ByteString -- ^ Initialization Vector
+ -> ByteString -- ^ Cipher text
+ -> Maybe ByteString
+aesDecrypt key iv ct = do
+ (ctx, iv', p) <- aesSetup key iv
+ let text' = cbcDecrypt ctx iv' ct
+ unpad p text'
+
+-- | Block size for AES128
+cipherBlockSize :: Int
+cipherBlockSize = 16
+
+genIV :: IO ByteString
+genIV = getRandomBytes cipherBlockSize
+
+aesSetup :: ByteArray a => a -> ByteString -> Maybe (AES128, IV AES128, Format)
+aesSetup key iv = (,,) <$> ctx <*> iv' <*> p
+ where
+ ctx = maybeCryptoError (cipherInit key)
+ iv' = makeIV iv
+ p = PKCS7 . blockSize <$> ctx
diff --git a/src/Network/Fernet/Key.hs b/src/Network/Fernet/Key.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Fernet/Key.hs
@@ -0,0 +1,89 @@
+module Network.Fernet.Key
+ ( Key(..)
+ , key
+ , generateKey
+ , generateKeyFromPassword
+ , keyFromBase64
+ , keyToBase64
+ ) where
+
+import Data.Monoid ((<>))
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import Data.Byteable (Byteable(..))
+import Data.ByteArray (ScrubbedBytes, ByteArrayAccess(..))
+import qualified Data.ByteArray as BA
+import qualified Crypto.KDF.PBKDF2 as PBKDF2
+import Crypto.Hash.Algorithms (SHA256(..))
+import Crypto.Random (getRandomBytes)
+
+import Network.Fernet.Base64
+
+-- | Contains the signing key and encryption key. Create one with
+-- 'key', 'keyFromBase64', or 'generateKeyFromPassword'.
+data Key = Key
+ { signingKey :: ScrubbedBytes
+ , encryptionKey :: ScrubbedBytes
+ } deriving (Show, Eq)
+
+-- | Constructs a pair of signing and encryption keys. Each key must
+-- be exactly 16 bytes long or this will fail.
+key :: ByteArrayAccess a
+ => a -- ^ Signing Key
+ -> a -- ^ Encryption Key
+ -> Maybe Key
+key s e = Key <$> toKey checkHashKeyLength s <*> toKey checkCipherKeyLength e
+
+toKey :: ByteArrayAccess a => (Int -> Bool) -> a -> Maybe ScrubbedBytes
+toKey checkLength k | checkLength (BA.length k) = Just (BA.convert k)
+ | otherwise = Nothing
+
+cipherKeyLength :: Int
+cipherKeyLength = 16
+
+-- | Check that key length is appropriate for AES128.
+checkCipherKeyLength :: Int -> Bool
+checkCipherKeyLength = (== cipherKeyLength)
+
+checkHashKeyLength :: Int -> Bool
+checkHashKeyLength = (>= 16)
+
+-- | Generates new keys from the PRNG.
+generateKey :: IO Key
+generateKey = splitKeys <$> getRandomBytes (cipherKeyLength * 2)
+
+-- | Input must be exactly length 32 chars
+splitKeys :: ByteString -> Key
+splitKeys = make . BS.splitAt cipherKeyLength
+ where make (s, e) = Key (BA.convert s) (BA.convert e)
+
+genSalt :: IO ByteString
+genSalt = getRandomBytes 16
+
+-- | Encodes the given key as urlsafe base64.
+keyToBase64 :: Key -> ByteString -- ^ URL-safe base64.
+keyToBase64 (Key s e) = b64url $ s <> e
+
+-- | Decodes urlsafe base64-encoded bytes into a key. This will fail
+-- if the input is not exactly 256 bits long (43 characters in
+-- base64).
+keyFromBase64 :: ByteString -- ^ URL-safe base64.
+ -> Either String Key
+keyFromBase64 = (>>= make) . b64urldec
+ where make s = case key sk ek of
+ Just k -> Right k
+ Nothing -> Left "Invalid key length"
+ where (sk, ek) = BS.splitAt ((BS.length s) - 16) s
+
+-- | Stretches the given password into a 'Key' using PBKDF2.
+generateKeyFromPassword :: Byteable p
+ => Int -- ^ Number of key derivation function iterations.
+ -> p -- ^ The password.
+ -> IO (Key, ByteString) -- ^ The key and random salt used.
+generateKeyFromPassword iterations p = do
+ salt <- genSalt
+ let keys = PBKDF2.generate prf params (toBytes p) salt
+ return (splitKeys keys, salt)
+ where
+ prf = PBKDF2.prfHMAC SHA256
+ params = PBKDF2.Parameters iterations 32
diff --git a/src/Network/Fernet/Token.hs b/src/Network/Fernet/Token.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Fernet/Token.hs
@@ -0,0 +1,87 @@
+module Network.Fernet.Token
+ ( encode
+ , decode
+ , serialize
+ , deserialize
+ , isExpired
+ , hasExpired
+ , hasExpired'
+ , TokenFields(..)
+ , Signature
+ ) where
+
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BL
+import Data.Word (Word8)
+import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
+import Data.Time.Clock (NominalDiffTime)
+import Data.Binary.Get
+import Data.Binary.Put
+
+import Network.Fernet.Base64
+
+data TokenFields = TokenFields
+ { tokenVersion :: Word8 -- ^ Version, 8 bits
+ , tokenTimestamp :: POSIXTime -- ^ Timestamp, 64 bits
+ , tokenIV :: ByteString -- ^ IV, 128 bits
+ , tokenCiphertext :: ByteString -- ^ Ciphertext, variable length, multiple of 128 bits
+ } deriving (Show, Eq)
+
+type Signature = ByteString
+
+-- | Size of a SHA256 hash.
+hmacLength :: Int
+hmacLength = 32
+
+encode :: ByteString -> Signature -> ByteString
+encode t s = b64url $ BS.concat [t, s]
+
+decode :: ByteString -> Either String (TokenFields, ByteString, Signature)
+decode = (>>= decode') . b64urldec
+ where
+ decode' bs = do
+ (t, sig) <- splitToken bs
+ tf <- deserialize t
+ return (tf, t, sig)
+ splitToken bs | BS.length sig < hmacLength = Left "Missing HMAC"
+ | otherwise = Right (t, sig)
+ where (t, sig) = BS.splitAt (BS.length bs - hmacLength) bs
+
+serialize :: TokenFields -> ByteString
+serialize TokenFields{..} = BL.toStrict . runPut $ do
+ putWord8 tokenVersion
+ putWord64be (floor tokenTimestamp)
+ putByteString tokenIV
+ putByteString tokenCiphertext
+
+deserialize :: ByteString -> Either String TokenFields
+deserialize t = case runGetOrFail get (BL.fromStrict t) of
+ Left (_, _, e) -> Left e
+ Right (_, _, tf) -> Right tf
+ where get = do
+ v <- getWord8
+ ts <- getWord64be
+ iv <- getByteString 16
+ ct <- BL.toStrict <$> getRemainingLazyByteString
+ return $! TokenFields v (fromIntegral ts) iv ct
+
+-- | Returns @Right True@ if the token has expired,
+-- @Left _@ if the token could not be parsed.
+hasExpired :: NominalDiffTime -- ^ TTL value.
+ -> ByteString -- ^ Encoded token.
+ -> IO (Either String Bool)
+hasExpired ttl token = isExpired ttl token <$> getPOSIXTime
+
+-- | Returns @Right True@ if the token is expired at the given time,
+-- @Left _@ if the token could not be parsed.
+isExpired :: NominalDiffTime -- ^ TTL value.
+ -> ByteString -- ^ Encoded token.
+ -> POSIXTime -- ^ The time to consider.
+ -> Either String Bool
+isExpired ttl token now = do
+ (tf, _, _) <- decode token
+ return $ hasExpired' ttl now tf
+
+hasExpired' :: NominalDiffTime -> POSIXTime -> TokenFields -> Bool
+hasExpired' ttl now TokenFields{..} = now - tokenTimestamp < ttl
diff --git a/test/Main.hs b/test/Main.hs
new file mode 100644
--- /dev/null
+++ b/test/Main.hs
@@ -0,0 +1,10 @@
+module Main where
+
+import Test.Tasty (defaultMain, testGroup)
+
+import qualified Network.Fernet.Tests
+
+main :: IO ()
+main = do
+ tests <- Network.Fernet.Tests.makeTests
+ defaultMain $ testGroup "Tests" [ tests ]
diff --git a/test/Network/Fernet/Tests.hs b/test/Network/Fernet/Tests.hs
new file mode 100644
--- /dev/null
+++ b/test/Network/Fernet/Tests.hs
@@ -0,0 +1,91 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+module Network.Fernet.Tests (makeTests) where
+
+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 Data.Maybe (fromJust, fromMaybe)
+import Data.Either (isLeft)
+import Data.Aeson
+import Control.Applicative
+import Data.Time.Clock (NominalDiffTime)
+import Data.Time.LocalTime (zonedTimeToUTC)
+import Data.Time.Format (parseTimeM, defaultTimeLocale)
+import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds)
+import GHC.Generics
+import System.IO
+
+import Test.QuickCheck
+import Test.QuickCheck.Monadic
+import qualified Test.QuickCheck as QC
+import qualified Test.QuickCheck.Monadic as QC
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (testCase)
+import Test.HUnit (Assertion, (@?=), assertFailure)
+
+import Network.Fernet
+
+data Spec = Spec
+ { desc :: String
+ , token :: ByteString
+ , now :: POSIXTime
+ , ttl :: NominalDiffTime
+ , secret :: ByteString
+ , src :: ByteString
+ , iv :: ByteString
+ } deriving (Generic, Show)
+
+instance FromJSON Spec where
+ parseJSON = withObject "Spec" $ \v -> Spec
+ <$> v .:? "desc" .!= ""
+ <*> liftA S8.pack (v .: "token")
+ <*> liftA (fromMaybe 0 . parseTime) (v .: "now")
+ <*> liftA (fromIntegral :: Int -> NominalDiffTime) (v .:? "ttl_sec" .!= 0)
+ <*> liftA S8.pack (v .: "secret")
+ <*> liftA S8.pack (v .:? "src" .!= "")
+ <*> liftA BS.pack (v .:? "iv" .!= [])
+
+parseTime :: Monad m => String -> m POSIXTime
+parseTime = fmap (utcTimeToPOSIXSeconds . zonedTimeToUTC) . parseTimeM False defaultTimeLocale fmt
+ where fmt = "%Y-%m-%dT%H:%M:%S%z"
+
+makeTests :: IO TestTree
+makeTests = do
+ generate <- makeGroup "generate" generateTest
+ verify <- makeGroup "verify" verifyTest
+ invalid <- makeGroup "invalid" invalidTest
+ return $ testGroup "Acceptance Tests" [ generate, verify, invalid ]
+
+makeGroup :: String -> (Spec -> TestTree) -> IO TestTree
+makeGroup name makeSpec = do
+ let f = "spec/" ++ name ++ ".json"
+ withFile f ReadMode $ \h -> do
+ c <- BL.hGetContents h
+ case eitherDecode' c of
+ Right specs -> return $ testGroup name (map makeSpec specs)
+ Left e -> return $ testGroup name [testCase ("Loading " ++ f) (assertFailure e)]
+
+getKey :: ByteString -> IO Key
+getKey secret = case keyFromBase64 secret of
+ Right key -> return key
+ Left e -> fail $ "Couldn't decode secret: " ++ e
+
+generateTest :: Spec -> TestTree
+generateTest Spec{..} = testCase "Token generation" $ do
+ key <- getKey secret
+ encrypt' key now iv src @?= token
+
+verifyTest :: Spec -> TestTree
+verifyTest Spec{..} = testCase "Successful token verification" $ do
+ key <- getKey secret
+ decrypt' key ttl now token @?= Right src
+
+invalidTest :: Spec -> TestTree
+invalidTest Spec{..} = testCase desc $ do
+ key <- getKey secret
+ let r = decrypt' key ttl now token
+ isLeft r @?= True
+