Simple Apple Push Notification on Haskell

APN.hs

-- Big respect to author of the article Apple Push Notifications with Haskell
-- http://bravenewmethod.com/2012/11/08/apple-push-notifications-with-haskell/
-- It is actually the same code, simplified for my needs

module APN where

import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.UTF8 as BU  
import Data.Binary.Put
import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime)
import Data.Word (Word8, Word32, Word16)
import Data.List (elemIndex)
import Data.Char (ord, chr, toUpper)
import Data.Bits (shift, (.|.), (.&.)) 
import Network.Socket as Socket
import Network.BSD (getHostByName, hostAddress, getProtocolNumber)
import OpenSSL
import OpenSSL.Session as SSL

sendAPNs :: B.ByteString -> String -> IO ()
sendAPNs payload token = withOpenSSL $ do
  
  -- Prepare SSL context
  ssl <- context
  contextSetPrivateKeyFile   ssl "key-noenc.pem"
  contextSetCertificateFile  ssl "cert.pem"
  contextSetDefaultCiphers   ssl
  contextSetVerificationMode ssl VerifyNone

  -- Open socket
  proto <- (getProtocolNumber "tcp")
  host  <- getHostByName "gateway.push.apple.com"
  sock  <- socket AF_INET Stream proto
  Socket.connect sock (SockAddrInet 2195 (hostAddress host))

  -- Promote socket to SSL stream
  sslsocket <- connection ssl sock
  SSL.connect sslsocket

  -- Prepare PDUs
  expiry  <- timeSinceNow 3600
  
  -- Send
  SSL.write sslsocket $ buildPDU token payload expiry
  
  -- Close
  SSL.shutdown sslsocket Unidirectional


------------------
-- Building PDU --
------------------

buildPDU :: String -> BU.ByteString -> POSIXTime -> B.ByteString
buildPDU token payload expiry
  | (length token) /= 64     = error "Invalid token"
  | (BU.length payload) > 255  = error "Too long payload"
  | otherwise = toStrict $ runPut $ do
    let btoken = hexToByteString token
        bexpiry = (round expiry) :: Word32
    putWord8 1
    putWord32be 1
    putWord32be bexpiry
    putWord16be (fromIntegral $ B.length btoken :: Word16)
    putByteString btoken
    putWord16be (fromIntegral $ B.length payload :: Word16)
    putByteString payload
    

-----------------------------------------
-- Convert Hex to ByteString (For PDU) --
-----------------------------------------

hexToByteString :: String -> B.ByteString
hexToByteString = B.pack . hexToWord8

hexToWord8 :: String -> [Word8]
hexToWord8 [] = []
hexToWord8 [_] = error "Invalid hex stream"
hexToWord8 (x:y:xs) = ((hn .|. ln) : hexToWord8 xs)
  where
    hn = shift (decodeNibble x) 4
    ln = decodeNibble y

decodeNibble :: Char -> Word8
decodeNibble x = index
  where 
    index = case (toUpper x) `elemIndex` table of
              (Just nibble) -> fromIntegral nibble :: Word8
              Nothing       -> error "Invalid hex stream"
    table = ['0','1','2','3','4','5','6','7','8','9', 'A', 'B', 'C', 'D', 'E', 'F']


-------------
-- Helpers --
-------------

timeSinceNow :: POSIXTime -> IO POSIXTime
timeSinceNow add = (+ add) <$> getPOSIXTime

toStrict :: BL.ByteString -> B.ByteString
toStrict = B.concat . BL.toChunks

Usage:

import qualified Data.ByteString as B
import APN

main = do
  let tokens = ["a61a882289aa73982be5b4cebbaf8fc6142fe24c5cc536e43f772faae995f627"
               ,"2582c5c337afe272e5e2ac9fb99a656e22112b34c1a36ce7c7e655a63618916f"]
  payload <- B.readFile "payload.json"
  mapM_ (sendAPNs payload) tokens

Example of payload.json:

{"aps":{"alert":"Simple Message from Haskell"}}

Two files key-noenc.pem and cert.pem should be available in current directory (directory from which the app is started, i.e. the pwd directory)

Those files should be created from p12:

openssl pkcs12 -in Certificates.p12 -out cert.pem -clcerts -nokeys
openssl pkcs12 -in Certificates.p12 -out key-noenc.pem -nocerts -nodes

And one IMPORTANT thing, use ghc -threaded when linking

Don't forget to update host (line 34), if you use sandbox