5
\$\begingroup\$

Here is my Haskell program designed to list all of my GitHub repos along with their descriptions and languages via the GitHub JSON APIs:

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}

module Main where

import Control.Monad
import Data.Aeson
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C8
import qualified Data.List as L
import Data.Maybe
import Data.Text
import qualified Data.Text.Encoding as E
import Data.Word (Word16)
import GHC.Generics (Generic)
import Network.Http.Client
import Network.HTTP.Link
import Network.URI
import OpenSSL

uriIsSsl :: URI -> Bool
uriIsSsl uri = uriScheme uri == "https:"

uriGetHostName :: URI -> Maybe String
uriGetHostName uri = uriRegName <$> uriAuthority uri

uriGetPort :: URI -> Word16 -> Maybe Word16
uriGetPort uri defaultPort = do
  auth <- uriAuthority uri
  return $ case uriPort auth of
                "" -> defaultPort
                p -> (Prelude.read $ Prelude.tail p) :: Word16

uriGetFullPath :: URI -> String
uriGetFullPath uri = uriPath uri ++ uriQuery uri ++ uriFragment uri

containsLinkParam :: Link -> LinkParam -> Text -> Bool
containsLinkParam link linkParam value =
  isJust $ L.find (\(lp, v) -> lp == linkParam && v == value) $ linkParams link

hasRelNext :: Link -> Bool
hasRelNext link = containsLinkParam link Rel "next"

findNextLink :: BS.ByteString -> Maybe Link
findNextLink value = do
  links <- parseLinkHeader $ E.decodeUtf8 value
  L.find hasRelNext links

getLinkHeader :: Response -> Maybe BS.ByteString
getLinkHeader p = getHeader p "Link"

nextLinkFromResponse :: Response -> Maybe Link
nextLinkFromResponse p = getLinkHeader p >>= findNextLink

openUri :: URI -> (Connection -> BS.ByteString -> IO a) -> IO a
openUri uri f =
  let
    isSsl = uriIsSsl uri
    hostName = C8.pack $ fromJust $ uriGetHostName uri
    port = fromJust $ uriGetPort uri (if isSsl then 443 else 80)
    fullPath = C8.pack $ uriGetFullPath uri
    wrappedF c = f c fullPath
  in
    if isSsl
       then
          withOpenSSL $ do
            ctx <- baselineContextSSL
            withConnection (openConnectionSSL ctx hostName port) wrappedF
       else
          withConnection (openConnection hostName port) wrappedF

data Repo = Repo {
    name :: String
  , description :: String
  , language :: Maybe String
} deriving (Show, Generic)

instance FromJSON Repo

fetchRepos :: URI -> IO [Repo]
fetchRepos uri =
  openUri uri $ \c fullPath -> do
    request <- buildRequest $ do
      http GET fullPath
      setAccept "application/json"
      setHeader "User-Agent" "MyGitHubApiClient"
    sendRequest c request emptyBody
    receiveResponse c $ \p i -> do
      repos <- jsonHandler p i
      nextRepos <- case nextLinkFromResponse p of
                        Just link -> fetchRepos $ href link
                        Nothing -> return []
      return $ repos ++ nextRepos

main :: IO ()
main = do
  repos <- fetchRepos $ fromJust $ parseURI "https://api.github.com/users/rcook/repos"
  putStrLn $ show (Prelude.length repos) ++ " repos:"
  forM_ repos $ \repo -> print repo

The trickiest thing I had to implement in this program was parsing and following "Link" headers in the HTTP response in order to deal with the API's built-in pagination behaviour. Fortunately, the http-link-header module exists so I didn't have to write the parser from scratch. However, figuring out where to follow the Rel="next" links was challenging at first.

I'm interested in hearing any constructive criticisms or suggestions, e.g.:

  • Code that could be refactored into more idiomatic Haskell style
  • Outright bugs
  • Improvements to error handling
  • Indentation!

I'd also welcome any suggestions about how I'd write automated tests for this code, given that much of the code is in the IO monad.

\$\endgroup\$
-2
\$\begingroup\$

You could add comments in your code to highlight important stages that the program passes through, not only this, but the code is more readable.

\$\endgroup\$
  • 4
    \$\begingroup\$ Just because you don't understand the code doesn't mean that everyone else also doesn't understand it. \$\endgroup\$ – Simon Forsberg Jan 6 '16 at 12:11

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.