Read SMS from a modem and put into a redis queue

sms2redis.hs

{-# LANGUAGE OverloadedStrings #-}

import Prelude hiding (concat)
import Data.ByteString.Char8 hiding (putStrLn)
import qualified Data.List as L
import Data.List.Split (chunk, splitOn)

import qualified Database.Redis as R
import System.IO (withFile, hFlush, Handle, IOMode(ReadWriteMode))
import System.Environment (getArgs)

import Control.Concurrent (threadDelay)
import Control.Monad
import Control.Monad.Trans (liftIO)
import Control.Monad.Trans.Writer (WriterT, execWriterT, tell)

import Private (modemPort, redisPwd)

-- * Container

data SMS = SMS { smsFrom :: !ByteString
               , smsTimestamp :: !ByteString
               , smsBody :: !ByteString
               } deriving (Eq, Show)

sms :: ByteString -> ByteString -> SMS
sms header body = SMS (getFrom header) (getTimestamp header) body
    where
        getFrom = pack . fst . fields
        getTimestamp = pack . snd . fields
        fields = toTuple . splitOn ("\",,\"" :: String) . L.last . splitOn ("\",\"" :: String) . L.init . unpack
        toTuple [f, s] = (f, s)

toRedis :: SMS -> ByteString
toRedis sms = concat [smsTimestamp sms, "\t", smsBody sms]

-- * Stream manipulation

getBlock :: Handle -> IO ByteString
getBlock h = execWriterT grab
    where
        grab :: WriterT ByteString IO ()
        grab = do
            liftIO $ threadDelay 250000
            stuff <- liftIO $ hGetNonBlocking h 102400
            case stuff of
                "" -> return ()
                _  -> tell stuff >> grab

processBlock :: ByteString -> [[ByteString]]
processBlock block = L.init . L.init . L.tail $ [split '\r' part | part <- split '\n' block]

runCmd :: Handle -> ByteString -> IO [[ByteString]]
runCmd h cmd = do
    -- flush
    hGetNonBlocking h 1024000

    -- speak
    hPutStrLn h $ concat [cmd, "\r"]

    -- listen
    block <- getBlock h
    return $ processBlock block

-- * Modem commands

listSMS :: Handle -> IO [SMS]
listSMS h = do
    block <- runCmd h "AT+CMGL=\"ALL\""
    case block of
        [] -> return []
        _  -> return [sms header msg | [header, msg] <- chunk 2 [item | [item, _] <- L.init block]]

readSMS :: Handle -> Int -> IO (Maybe SMS)
readSMS h n = do
    block <- runCmd h $ concat ["AT+CMGR=", pack $ show n]
    case block of
        [["+CMGR: 0,,0",""],["",""]] -> return Nothing
        [[header, _], [msg, _], _]   -> return $ Just (sms header msg)
        stuff                        -> putStrLn "Bad data:" >> print stuff >> return Nothing

delSMS :: Handle -> Int -> IO ()
delSMS h smsId = void $ runCmd h $ concat ["AT+CMGD=", pack $ show smsId]

flushSMS :: Handle -> IO ()
flushSMS h = do
    block <- runCmd h "AT+CMGL=\"ALL\""
    let ids = [read . L.head . L.drop 1 . splitOn ": " . L.head . splitOn ",\"" . unpack . L.head $ h | [h, _] <- chunk 2 block, h /= [""]]
    forM_ ids $ delSMS h
    print ids

-- * Handlers

incoming :: R.Connection -> Handle -> Int -> IO ()
incoming r h smsId = do
    Just sms <- readSMS h smsId
    let key = concat ["sms:incoming:", smsFrom sms]
    print (key, sms)
    R.runRedis r $ R.rpush key [toRedis sms] -- [concat [header, "\t", body]]
    delSMS h smsId

watch :: R.Connection -> Handle -> IO ()
watch r h = do
    line <- hGetLine h
    putStrLn $ "... " ++ show line
    process $ unpack line
    where
        process "\r" = print "empty."
        process "OK\r" = print "intervention!"
        process l | "+CMTI:" `L.isPrefixOf` l = incoming r h $ read . L.init . L.drop 12 $ l
        process l = putStrLn $ "unknown: " ++ show l

pipe :: Handle -> IO ()
pipe h = forever $ hGetLine h >>= (putStrLn . unpack)

doNothing :: R.Connection -> Handle -> IO ()
doNothing r h = print "hi!"

work :: R.Connection -> Handle -> IO ()
work r h = do
    args <- getArgs

    -- flush port
    hGetNonBlocking h 1024000

    -- init stuff
    runCmd h "AT"
    runCmd h "AT+CMGF=1"
    runCmd h "AT+CNMI=2,1,0,2,1"
    -- pipe h

    -- check our mailbox
    listSMS h >>= print
    readSMS h 1 >>= print
    if  "--flush" `L.elem` args
        then flushSMS h
        else return ()

    -- dump the stream
    forever $ watch r h

testHeader = "+CMGR: \"REC UNREAD\",\"TURKIYE.FIN\",,\"12/07/27,16:44:11+12\""
testBody = "Mobil SMSSifre: 1234. Action: Online banking login TURKIYE FINANS"

main :: IO ()
main = do
    --print $ sms testHeader testBody
    rcon <- R.connect R.defaultConnectInfo {R.connectPort = R.UnixSocket "redis.sock", R.connectAuth = Just (pack redisPwd)}
    withFile modemPort ReadWriteMode $ work rcon
    --return ()