hs-zipcode.cabal

Name: hs-zipcode
Version: 0.0.1
Build-type: Simple
Build-Depends: base,
	       bytestring-csv,
	       bytestring,
	       network,
	       httpd-shed,
	       json,
	       containers

ghc-options: -O2     
Executable: hszip
Main-Is: Main.hs

Main.hs

module Main where
 
import System.Environment(getArgs)
import qualified Data.ByteString as L
import qualified Data.ByteString.Char8 as L8
import Text.CSV.ByteString
import Control.Monad
import Control.Applicative
import Data.List
import Data.Char
import Data.String
import qualified Data.Map as Map
import Data.Map((!))
import Network.Shed.Httpd
import Network.URI
import Text.JSON
 
type ZipCode = String
type ZipData = Map.Map String String
type ZipCodes = Map.Map ZipCode ZipData
 
main = getArgs >>= run
    where run [port, path] = serve ((read port)::Int) path
          run _                     = error "hszip PORT ZIPFILE"
 
loadFile :: FilePath -> IO (Map.Map ZipCode ZipData)
loadFile path = L.readFile path >>= \contents ->
                case parseCSV contents of
                  Nothing -> error $ "Unable to load " ++ path
                  Just (h:zipcodes) -> return (buildMap h zipcodes)
                    where buildMap h zipcodes = foldl step Map.empty al
                          step m r = Map.insert (r ! "zip") r m
                          al = map (\r -> Map.fromList $ zip headers (unpack r)) zipcodes
                          headers = map ((map toLower) . L8.unpack) h
                          unpack = map L8.unpack
 
serve :: Int -> FilePath -> IO Server
serve port path = loadFile path >>= \zipcodes -> initServer port (dispatch zipcodes)
 
badRequest :: IO Response
badRequest = return $ Response 404 [] $ encode "Bad Request"
 
goodResponse :: JSON a => a -> IO Response
goodResponse s = return $ Response 200 [] $ encode s
 
dispatch :: ZipCodes -> Request -> IO Response
dispatch zipcodes req = proReq zipcodes (split '/' path) req
    where args = queryToArguments (uriQuery (reqURI req))
          path = uriPath (reqURI req)
 
proReq :: ZipCodes -> [String] -> Request -> IO Response
proReq zipcodes ["zip", z] req = case searchZipCode z zipcodes of
                                   Nothing -> badRequest
                                   Just l -> goodResponse l
 
proReq zipcodes ["zip", z, d] req = 
    goodResponse $ Map.filterWithKey (\k a -> r >= (distance x a)) zipcodes
        where r = (read d)::Double
              x = zipcodes ! z
 
proReq zipcodes ["zip", z1, "distance", z2] req = goodResponse $ distance (zipcodes ! z1) (zipcodes ! z2)
 
proReq _ _ _ = badRequest
 
searchZipCode :: String -> ZipCodes -> Maybe ZipCodes
searchZipCode z zipcodes = result $ Map.filterWithKey (\k _ -> isPrefixOf z k) zipcodes
    where result zs | (zs == Map.empty) = Nothing
          result zs = Just zs
          
distance :: ZipData -> ZipData -> Double
distance p1 p2 = r * acos ((sin lat1) * (sin lat2) + 
                           (cos lat1) * (cos lat2) * (cos (lon2 - lon1)))
    where rad k p = ((read $ p ! k) * pi) / 180
          lat1 = rad "lat" p1
          lon1 = rad "lng" p1
          lat2 = rad "lat" p2
          lon2 = rad "lng" p2
          r = 3963.0 -- miles
 
split :: Eq a => a -> [a] -> [[a]]
split _   [] = []
split sep s  = filter (/= []) $ pre : case rest of
                                        sep:tail -> (split sep tail)
                                        _ -> []
    where (pre, rest) = break (== sep) s