diff --git a/Passbook.hs b/Passbook.hs --- a/Passbook.hs +++ b/Passbook.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} @@ -58,18 +59,23 @@ import Control.Monad (liftM) import Control.Monad.IO.Class (liftIO) import Data.Aeson +import Data.Binary (Word32) +import Data.Bits (shiftR, (.&.)) import qualified Data.ByteString.Lazy as LB +import Data.Char (intToDigit) import Data.Conduit import Data.Conduit.Binary hiding (sinkFile) -import Data.Conduit.Filesystem +import Data.Conduit.Combinators (sinkFile) +import Control.Monad.Trans.Resource import qualified Data.Text as ST import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as LT import Data.UUID import Filesystem.Path (filename) -import Filesystem.Path.CurrentOS (encodeString) +import Filesystem.Path.CurrentOS (encodeString, decodeString) import Passbook.Types import Prelude hiding (FilePath) +import Shelly (FilePath) import Shelly import System.Directory (doesFileExist) import System.Random @@ -139,31 +145,32 @@ let tmp = passOut passId lazyId = LT.fromStrict passId cp_r passIn tmp - liftIO $ renderPass (tmp "pass.json") pass { serialNumber = passId } + liftIO $ renderPass (tmp ((Shelly.fromText "pass.json") :: FilePath)) pass { serialNumber = passId } signcmd lazyId tmp passOut rm_rf tmp - return (passOut LT.append lazyId ".pkpass") + return (passOut LT.unpack (LT.append lazyId ".pkpass")) -- |Helper function to generate a hash genHash :: FilePath -> Sh (Text, Text) genHash file = do rawhash <- run "openssl" ["sha1", toTextIgnore file] - let hash = LT.drop 1 $ LT.dropWhile (/= ' ') rawhash - return (toTextIgnore $ filename file, LT.filter (/= '\n') hash) + let hash = LT.drop 1 $ LT.dropWhile (/= ' ') (LT.fromStrict rawhash) + return (LT.fromStrict (toTextIgnore $ encodeString $ filename (decodeString file)), LT.filter (/= '\n') hash) -- |Render JSON and put it in a file saveJSON :: ToJSON a => a -> FilePath -> IO () -saveJSON json path = LB.writeFile (LT.unpack $ toTextIgnore path) $ encode json +saveJSON json path = LB.writeFile (ST.unpack $ toTextIgnore path) $ encode json -- |Helper function to sign the manifest sslSign :: FilePath -- ^ Certificate -> FilePath -- ^ Key -> FilePath -- ^ Temporary directory containing manifest.json - -> Sh Text + -> Sh ST.Text sslSign cert key tmp = run "openssl" [ "smime", "-binary" , "-sign" , "-signer", toTextIgnore cert + , "-certfile", "wwdr.pem" , "-inkey" , toTextIgnore key , "-in", "manifest.json" , "-out", "signature" @@ -230,20 +237,36 @@ let tmp = passOut passId passFile = LT.append (LT.fromStrict $ passId) ".pkpass" cp_r passIn tmp - liftIO $ renderPass (tmp "pass.json") (pass { serialNumber = passId }) + liftIO $ renderPass (tmp Shelly.fromText ("pass.json" :: ST.Text)) (pass { serialNumber = passId }) cd tmp manifest <- liftM Manifest $ pwd >>= ls >>= mapM genHash - liftIO $ saveJSON manifest (tmp "manifest.json") + liftIO $ saveJSON manifest (tmp ("manifest.json" :: FilePath)) sslSign cert key tmp - files <- liftM (map (toTextIgnore . filename)) $ ls =<< pwd - run "zip" ((toTextIgnore $ passOut passFile) : files) + files <- liftM (map (\f -> toTextIgnore (encodeString $ filename (decodeString f)))) $ ls =<< pwd + run "zip" ((toTextIgnore $ passOut (LT.unpack passFile)) : files) rm_rf tmp - return (passOut passFile) + return (passOut (LT.unpack passFile)) -- |Generates a random UUID for a Pass using "Data.UUID" and "System.Random" genPassId :: IO ST.Text -genPassId = liftM (ST.pack . toString) randomIO +genPassId = liftM (ST.pack . showPassId) randomIO +-- |Shows a UUID without the hyphens +showPassId :: UUID -> String +showPassId uuid = let (w0, w1, w2, w3) = toWords uuid + in hexw w0 $ hexw' w1 $ hexw' w2 $ hexw w3 "" + where hexw :: Word32 -> String -> String + hexw w s = hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16 + : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s + + hexw' :: Word32 -> String -> String + hexw' w s = hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16 + : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s + + hexn :: Word32 -> Int -> Char + hexn w r = intToDigit $ fromIntegral ((w `shiftR` r) .&. 0xf) + + -- |Render and store a pass.json at the desired location. renderPass :: FilePath -> Pass -> IO () renderPass path pass = @@ -257,7 +280,7 @@ -> Sh () signcmd uuid assetFolder passOut = run_ "signpass" [ "-p", toTextIgnore assetFolder -- The input folder - , "-o", toTextIgnore $ passOut LT.append uuid ".pkpass" ] -- Name of the output file + , "-o", toTextIgnore $ passOut LT.unpack (LT.append uuid ".pkpass") ] -- Name of the output file -- |Tries to parse the pass.json file contained in a .pkpass into a valid -- 'Pass'. If Passbook accepts the .pkpass file, this function should never @@ -265,7 +288,7 @@ loadPass :: FilePath -- ^ Location of the .pkpass file -> IO (Maybe Pass) loadPass path = do - archive <- liftM toArchive $ LB.readFile $ encodeString path + archive <- liftM toArchive $ LB.readFile $ path case findEntryByPath "pass.json" archive of Nothing -> return Nothing Just pass -> return $ decode $ fromEntry pass diff --git a/Passbook/Types.hs b/Passbook/Types.hs --- a/Passbook/Types.hs +++ b/Passbook/Types.hs @@ -5,6 +5,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fdefer-type-errors #-} {- |This module provides types and functions for type-safe generation of PassBook's @pass.json@ files. @@ -49,10 +50,12 @@ import qualified Data.HashMap.Strict as HM import Data.Text (Text, pack, unpack) import qualified Data.Text.Lazy as LT +import Data.String (fromString) import Data.Time import Data.Typeable -import System.Locale +import System.Locale hiding (iso8601DateFormat, timeFmt, defaultTimeLocale) import Text.Shakespeare.Text +import Data.Scientific (floatingOrInteger) -- | Auxiliary type to ensure that field values are rendered correctly data PassValue = PassInt Integer @@ -102,11 +105,11 @@ deriving (Eq, Ord, Show, Read, Typeable) -- |Pass field date/time display style -data DateTimeStyle = None -- ^ Corresponds to @NSDateFormatterNoStyle@ - | Short -- ^ Corresponds to @NSDateFormatterShortStyle@ - | Medium -- ^ Corresponds to @NSDateFormatterMediumStyle@ - | Long -- ^ Corresponds to @NSDateFormatterLongStyle@ - | Full -- ^ Corresponds to @NSDateFormatterFullStyle@ +data DateTimeStyle = None -- ^ Corresponds to @PKDateStyleNone@ + | Short -- ^ Corresponds to @PKDateStyleShort@ + | Medium -- ^ Corresponds to @PKDateStyleMedium@ + | Long -- ^ Corresponds to @PKDateStyleLong@ + | Full -- ^ Corresponds to @PKDateStyleFull@ deriving (Eq, Ord, Show, Read, Typeable) -- |Pass field number display style @@ -169,7 +172,9 @@ -- |A complete pass data Pass = Pass { -- Required keys - description :: Text -- ^ Brief description of the pass (required) + expirationDate :: Maybe Text + , voided :: Maybe Bool + , description :: Text -- ^ Brief description of the pass (required) , organizationName :: Text -- ^ Display name of the organization that signed the pass (required) , passTypeIdentifier :: Text -- ^ Pass type identifier, as issued by Apple (required) , serialNumber :: Text -- ^ Unique serial number for the pass (required) @@ -201,7 +206,7 @@ instance ToJSON Manifest where toJSON (Manifest files) = - let pairs = map (\(f, h) -> LT.toStrict f .= h) files + let pairs = map (\(f, h) -> (fromString $ unpack $ LT.toStrict f) .= h) files in object pairs -- * JSON instances @@ -210,9 +215,9 @@ -- because Passbook can't deal with null values in JSON. (-:) :: ToJSON a => Text -> Maybe a -> [Pair] -> [Pair] (-:) _ Nothing = id -(-:) key (Just value) = ((key .= value) :) +(-:) key (Just value) = (((fromString $ unpack $ key) .= value) :) -$(deriveToJSON id ''PassContent) +$(deriveToJSON defaultOptions ''PassContent) instance ToJSON Location where toJSON Location{..} = @@ -248,6 +253,8 @@ toJSON Pass{..} = let pairs = ("relevantDate" -: relevantDate) $ ("barcode" -: barcode) + $ ("expirationDate" -: expirationDate) + $ ("voided" -: voided) $ ("backgroundColor" -: backgroundColor) $ ("foregroundColor" -: foregroundColor) $ ("labelColor" -: labelColor) @@ -263,7 +270,7 @@ , "teamIdentifier" .= teamIdentifier , "associatedStoreIdentifiers" .= associatedStoreIdentifiers , "locations" .= locations - , passTypeName passContent .= passContent] + , (fromString $ unpack $ passTypeName passContent) .= passContent] in object pairs -- |Internal helper function to handle Boarding Passes correctly. @@ -313,11 +320,11 @@ toJSON Natural = toJSON ("PKTextAlignment" :: Text) instance ToJSON DateTimeStyle where - toJSON None = toJSON ("NSDateFormatterNoStyle" :: Text) - toJSON Short = toJSON ("NSDateFormatterShortStyle" :: Text) - toJSON Medium = toJSON ("NSDateFormatterMediumStyle" :: Text) - toJSON Long = toJSON ("NSDateFormatterLongStyle" :: Text) - toJSON Full = toJSON ("NSDateFormatterFullStyle" :: Text) + toJSON None = toJSON ("PKDateStyleNone" :: Text) + toJSON Short = toJSON ("PKDateStyleShort" :: Text) + toJSON Medium = toJSON ("PKDateStyleMedium" :: Text) + toJSON Long = toJSON ("PKDateStyleLong" :: Text) + toJSON Full = toJSON ("PKDateStyleFull" :: Text) instance ToJSON NumberStyle where toJSON Decimal = toJSON ("PKNumberStyleDecimal" :: Text) @@ -350,7 +357,7 @@ -- |Helper function that parses a 'UTCTime' out of a Text parseJsonDate :: Text -> Maybe UTCTime -parseJsonDate = parseTime defaultTimeLocale timeFormat . unpack +parseJsonDate = parseTimeM True defaultTimeLocale timeFormat . unpack -- * Implementing FromJSON @@ -365,11 +372,11 @@ instance FromJSON DateTimeStyle where parseJSON (String t) = case t of - "NSDateFormatterNoStyle" -> pure None - "NSDateFormatterShortStyle" -> pure Short - "NSDateFormatterMediumStyle" -> pure Medium - "NSDateFormatterLongStyle" -> pure Long - "NSDateFormatterFullStyle" -> pure Full + "PKDateStyleNone" -> pure None + "PKDateStyleShort" -> pure Short + "PKDateStyleMedium" -> pure Medium + "PKDateStyleLong" -> pure Long + "PKDateStyleFull" -> pure Full _ -> fail "Could not parse date formatting style" parseJSON _ = mzero @@ -417,8 +424,9 @@ parseJSON _ = mzero instance FromJSON PassValue where - parseJSON (Number (I i)) = pure $ PassInt i - parseJSON (Number (D d)) = pure $ PassDouble d + parseJSON (Number num) = case floatingOrInteger num of + Left d -> pure $ PassDouble d + Right i -> pure $ PassInt i parseJSON (String t) = case parseJsonDate t of Just d -> pure $ PassDate d Nothing -> pure $ PassText t @@ -445,7 +453,7 @@ Nothing -> fail "Could not parse relevant date" parseJSON _ = mzero -$(deriveFromJSON id ''PassContent) +$(deriveFromJSON defaultOptions ''PassContent) -- |Tries to parse a web service parseWebService :: Maybe Text -> Maybe Text -> Maybe WebService diff --git a/hs-pkpass.cabal b/hs-pkpass.cabal --- a/hs-pkpass.cabal +++ b/hs-pkpass.cabal @@ -1,42 +1,47 @@ --- Initial hs-pkpass.cabal generated by cabal init. For further +-- Initial hs-pkpass.cabal generated by cabal init. For further -- documentation, see http://haskell.org/cabal/users-guide/ name: hs-pkpass -version: 0.4 +version: 0.6 synopsis: A library for Passbook pass creation & signing description: A Haskell library for type-safe creation of Passbook passes and signing through Apple's signpass tool. homepage: https://github.com/tazjin/hs-pkpass license: BSD3 license-file: LICENSE author: Vincent Ambo -maintainer: geva@humac.com --- copyright: +maintainer: marc@digitallyinduced.com +-- copyright: category: Apple build-type: Simple -cabal-version: >=1.8 +cabal-version: >=1.10 source-repository head type: git - location: https://github.com/tazjin/hs-pkpass.git + location: https://github.com/digitallyinduced/hs-pkpass.git library + default-language: Haskell2010 exposed-modules: Passbook, Passbook.Types - -- other-modules: + -- other-modules: build-depends: base >= 4 && < 5, directory >= 1 && < 2, - aeson ==0.6.*, - conduit ==0.5.*, - filesystem-conduit ==0.5.*, - text ==0.11.*, - uuid ==1.2.*, - shelly ==0.14.*, - random == 1.0.*, - time ==1.4.*, - old-locale ==1.0.*, - shakespeare-text ==1.0.*, + aeson >= 0.6, + conduit >= 0.5, + conduit-extra, + resourcet, + shakespeare, + text >= 0.11, + uuid >= 1.2, + shelly >= 0.14, + random >= 1.0, + time >= 1, + old-locale >= 1.0, + shakespeare-text >= 1.0, attoparsec >= 0.8.6.1, unordered-containers >= 0.2, zip-archive >= 0.1.1.8, system-filepath < 0.5, bytestring, - transformers >= 0.3 + transformers >= 0.3, + binary >= 0.5, + scientific