15
\$\begingroup\$

I'd really appreciate some harsh/constructive criticism of what I would consider as my first program in Haskell. The program should download all of the xkcd comics into a folder in the current directory.

I basically just threw the kitchen sink at it, using anything I found remotely interesting in RWH and on the Haskell wiki, so I'm 99% sure most of it is unnecessary or overkill. I tried using most popular libraries I could find. I wasn't clear on how to handle errors, how to deal with the filesystem efficiently, and how to use Text.JSON correctly.

hpaste link

    {-# Language PackageImports #-}
module Main where

import System.FilePath (takeFileName, (</>))
import System.IO 
import System.Environment
import System.Posix.User
import System.Directory
import Control.Monad (liftM, forM_, replicateM_)
import Control.Concurrent (forkIO)
import Control.Concurrent.STM
import Data.List (delete)
import Network.HTTP
import qualified Data.ByteString.Lazy.Char8 as L
import "mtl" Control.Monad.Error
import Network.URI (parseURI)
import Control.Applicative
import Control.Exception
import qualified Network.Stream as Stream (Result) 
import Control.Arrow
import Text.JSON

----------------------------------------------------------------------
main = do
  dir <- makeComicDir
  putStrLn $ "Created " ++ dir
  Right json <- xkcdFetchJSON Current
  let curNum = xkcdGetNumber json "num"
      comics = take curNum $ iterate (subtract 1) curNum
  putStrLn $ "Downloading " ++ (show $ length comics) ++ " comics..."
  comicQueue <- newTChanIO
  atomically $ forM_ (ComicNumber <$> comics) $ writeTChan comicQueue
  workers <- newTVarIO 8
  replicateM_ 8  . forkIO $ worker comicQueue workers dir
  waitFor workers
  putStrLn "DONE"
----------------------------------------------------------------------
data ComicNumber = Current | ComicNumber Int deriving (Show)

getReq = fmap (mkRequest GET) . parseURI

getRequestE = maybe (throwError "invalid url") return . getReq

tryRequest :: Request_String
           -> IO (Either IOException (Stream.Result (Response String)))

tryRequest = try . simpleHTTP

simpleHttpE request = do
  response <- liftIO $ tryRequest request
  case response of
    Left  err -> throwError $ show err
    Right rsp -> return rsp

getResponseBodyE = either (throwError.show) (return.rspBody)

fetchHtmlA = Kleisli getRequestE >>>
             Kleisli simpleHttpE >>>
             Kleisli getResponseBodyE

fetchHTMLBody url = runErrorT $ runKleisli fetchHtmlA url
----------------------------------------------------------------------
xkcd = "http://xkcd.com/"

xkcdJSONUrl Current          = xkcd ++ "info.0.json"
xkcdJSONUrl (ComicNumber n)  = xkcd ++ show n ++ "/info.0.json"

xkcdFetchJSON :: ComicNumber -> IO (Either String String)
xkcdFetchJSON num = runErrorT $ runKleisli fetchHtmlA $ xkcdJSONUrl num

xkcdComicUrl :: ComicNumber -> IO String
xkcdComicUrl num = do
  Right jstr <- xkcdFetchJSON num
  let (Ok (JSObject jobj)) = decode jstr
      (Ok img) = valFromObj "img" jobj
  return img

xkcdGetNumber :: String -> String -> Int
xkcdGetNumber jstr key = 
  let (Ok (JSObject jobj)) = decode jstr
      (Ok jval) = valFromObj key jobj
  in jval

----------------------------------------------------------------------
getImgName = takeFileName

downloadComic dir num = do
  url <- xkcdComicUrl num 
  let (ComicNumber n) = num
      name = (show n) ++ "_" ++ getImgName url
      path = dir </> name
  comic <- fetchHTMLBody url
  case comic of
    Left  err -> putStrLn $ "ERROR: " ++ show err
    Right img -> do
      file <- openBinaryFile path WriteMode
      hPutStr file img
      hClose file
      putStrLn $ "Saving " ++ name

makeComicDir = do 
  homedir <- getHomeDirectory
  let imgdir = homedir </> ".xkcd"
  createDirectory imgdir
  return imgdir

worker jobs alive dir = work
  where quit = atomically $ readTVar alive >>= writeTVar alive . (subtract 1)
        cont = do job@(ComicNumber n) <- atomically $ readTChan jobs
                  if' (n == 404) work $ downloadComic dir job >> work
        work = (atomically $ isEmptyTChan jobs) >>= \x -> if' x quit cont

waitFor alive = atomically $ readTVar alive >>= check . (==0)

----------------------------------------------------------------------
if' :: Bool -> a -> a -> a
if' True x _  = x
if' False _ y = y
\$\endgroup\$

migrated from stackoverflow.com May 23 '11 at 20:57

This question came from our site for professional and enthusiast programmers.

  • \$\begingroup\$ simpleHttpE seems to be converting Either to an IO Exception, right after tryRequest converts the IO exception to Either. Is this not redundant? \$\endgroup\$ – Anonymous May 23 '11 at 4:04
  • \$\begingroup\$ comics = reverse [1..curNum] \$\endgroup\$ – Anonymous May 23 '11 at 7:59
  • 1
    \$\begingroup\$ The Kleisli stuff is just Kleisli composition, isn't it? Use <=<. \$\endgroup\$ – Anonymous May 23 '11 at 8:00
10
\$\begingroup\$

Looks pretty good. You're getting on top of stuff nicely. Some criticism:

  • don't use package imports
  • write type signatures for top level functions
  • write comments!
  • thread design looks good.
  • don't use if'. Haskell has if already.
  • Kleisli needs documentation. Starting to go overboard at this point.
  • don't mix too many concepts in one program: the code won't be maintainable.
\$\endgroup\$
  • \$\begingroup\$ Thanks. Some of the type signatures were awfully long so I wasn't sure whether to include them or not. \$\endgroup\$ – Anonymous May 23 '11 at 2:54
  • 1
    \$\begingroup\$ Perhaps write type synonyms for the major part of the design? \$\endgroup\$ – Anonymous May 23 '11 at 3:16
  • 2
    \$\begingroup\$ I really like using if as a function instead of a keyword. It's more intuitive for me and the syntax seems more readable. Is there any if function in the standard libraries? \$\endgroup\$ – Anonymous May 23 '11 at 14:33
  • \$\begingroup\$ @Anonymous if there were, you would be able to find it by putting its type into Hoogle. So I guess not. \$\endgroup\$ – MatrixFrog Jul 6 '11 at 7:33
  • 1
    \$\begingroup\$ Haskell's if-then-else can be a bit of a straightjacket sometimes -- such as when you don't want an "else" clause. There's a whole discussion about if' here: haskell.org/haskellwiki/If-then-else \$\endgroup\$ – rtperson Jul 6 '11 at 16:09

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.