[Haskell] SNTPクライアントを書く その２

Haskellで書いたUDPクライアントの、
[Haskell] SNTPクライアントを書く その１
http://qiita.com/saltheads/items/3beab6e141a5d7abe73d
をできるだけアプリカティブスタイルになるように書き換えてみた。また、hlintにかけて指摘をとった。

doは１つ以外すべてを取り除いたが１つだけ取れなかった。

ApplicativeSntpClient.hs

{-# OPTIONS -Wall -Werror #-}
module Main where
-- | NTPパケットの送受信に ByteString.Char8 を使用する
import Network.Socket hiding (sendTo,recvFrom)
import Network.Socket.ByteString
import qualified Data.ByteString.Char8 as B
import Data.Char (chr, ord)
import System.Timeout
-- import Control.Exception
-- | 時刻
import Data.Time.Clock
import Data.Time.Format
import Data.Time.Calendar
import Data.Time.LocalTime
import System.Locale
-- | アプリカティブ
import Control.Applicative hiding ((<|>),many)

-- | convert big-endian ByteString to Int
big :: B.ByteString -> Int
big = B.foldl (\a c -> a*256 + ord c) 0

-- | convert little-endian ByteString to Int
little :: B.ByteString -> Int
little = B.foldr (\c a -> a*256 + ord c) 0

-- | B.ByteStringのfromバイト目からsizeバイト分を big-endianで読んで Intとして返す
bigN :: Int -> Int -> B.ByteString -> Int
bigN from size = big . B.take size . B.drop from

-- | NTP リクエスト
request :: B.ByteString
request = B.pack $ map chr (0x0b : replicate 47 0)

-- | NTP レスポンスからtransmit_timestamp_secondsを得る
getSeconds :: B.ByteString -> Int
--getSeconds = big . (B.take 4) . (B.drop 40)
getSeconds = bigN 40 4

-- | 70年分の秒数
seventyYears :: Int
seventyYears = (*) (24*60*60::Int) (fromInteger days)
                where days = diffDays (fromGregorian 1970 1 1) 
                                      (fromGregorian 1900 1 1)
-- | サーバ名型
type ServerName = String

-- | NTPサーバ
server1 :: ServerName
server1 = "ntp.nict.jp" -- | 日本標準時 NTPサーバ

-- | NTPポート
port1 :: PortNumber
port1 = 123

-- | メイン
main  :: IO ()
main = sntpClient server1 port1
       >> zonedTime >>= (\t -> putStrLn ("pc_zoned   [" ++ t ++ "]"))
       >> currentTime >>= (\t -> putStrLn ("pc_current [" ++ t ++ "]"))

-- | 名前解決
getHostAddr :: ServerName -> IO HostAddress
getHostAddr server = 
        (takeWhile (/=':') . show . addrAddress . head)
        <$> getAddrInfo Nothing (Just server) (Just "http")
        >>= inet_addr

-- | SNTPクライアント (UDPクライアント)
-- | withSocketsDo :: IO a -> IO a
sntpClient :: ServerName -> PortNumber -> IO ()
sntpClient server port = withSocketsDo $ do
        hostAddr <- getHostAddr server
        soc <- socket AF_INET Datagram defaultProtocol
        -- | このあとsocを3箇所で使っている。そのためアプリカティブにするのは困難
        _ <- sendTo soc request (SockAddrInet port hostAddr)
        tpl <- timeout (5*1000*1000) $ recvFrom soc 256
        close soc
        case tpl of
          -- | SNTPでは1900年からの秒数が返ってくるので、
          -- | それを1970年からの秒数に変換するために70年分引く
          Just (response,_) -> let epocTime = getSeconds response - seventyYears
                               in showTime epocTime
          Nothing  -> error "error"

-- | 時刻表示フォーマット
format :: UTCTime -> String
format = formatTime defaultTimeLocale "%Y/%m/%d %H:%M:%S"
     
-- | 時刻表示
showTime :: Int -> IO ()
showTime epocTime = 
     putStrLn ("epocTime   [" ++ show epocTime ++ "]")
     >> -- | UTCTimeを作る
       let utcTime = readTime defaultTimeLocale "%s" (show epocTime) :: UTCTime
       in putStrLn ("utc        [" ++ show utcTime ++ "]")
     >> -- | Asia/Tokyoの時差9時間を足す
       let zoned = addUTCTime (9*60*60) utcTime
       in putStrLn ("format     [" ++ format zoned ++ "]")

-- | PCの時刻取得
-- | formatTime :: FormatTime t => TimeLocale -> String -> t -> String
zonedTime :: IO String
zonedTime = formatTime defaultTimeLocale "%Y/%m/%d %H:%M:%S %z" <$> getZonedTime

-- | PCの時刻取得
currentTime :: IO String
currentTime = formatTime defaultTimeLocale "%Y/%m/%d %H:%M:%S %z" <$> getCurrentTime

実行結果

$ hlint ApplicativeSntpClient.hs 
No suggestions

$ runghc --version
runghc 7.8.3

$ runghc ApplicativeSntpClient.hs 
epocTime   [1410961030]
utc        [2014-09-17 13:37:10 UTC]
format     [2014/09/17 22:37:10]
pc_zoned   [2014/09/17 22:37:10 +0900]
pc_current [2014/09/17 13:37:10 +0000]

なんとなく、m1 where s1 よりも、let s1 in m1 のほうが好き。