Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
executable file 159 lines (129 sloc) 5.54 KB
#!/usr/bin/env runhaskell
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main (main) where
import Prelude hiding (catch)
import Control.Applicative ((<$>))
import Control.Exception (IOException, catch)
import Control.Lens
import Control.Monad (forM_)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource (register)
import Data.Aeson
import Data.Conduit (ResourceT, ($$+-))
import Data.Conduit.Binary (sinkFile)
import Data.Data (Data, Typeable)
import Data.Data.Lens (uniplate)
import Data.List (delete)
import qualified Data.Map as Map
import qualified Data.Text.Lens as T
import Network.HTTP.Conduit
import Network.HTTP.Types (hContentType, parseQuery,
renderQuery)
import Network.Socket (withSocketsDo)
import System.Environment (getArgs, getProgName)
import System.Exit (exitFailure)
import System.FilePath ((</>))
import System.IO (hPutStrLn, stderr)
import System.Posix.Files (createSymbolicLink, removeLink,
rename)
-- Evil orphan instance.
deriving instance Data Value
data Env = Env { envManager :: Manager
, envLookupNames :: String -> Maybe [String]
, envOutputDir :: String
}
deriving (Typeable)
data Author = Author { authorLogin :: String
, authorImageURI :: String
}
deriving (Eq, Ord, Show, Read, Typeable, Data)
main :: IO ()
main = withSocketsDo . withManager $ \man -> do
args <- liftIO getArgs
case args of
[jsonUri, nameMapPath, outputDir] -> do
namesList <- liftIO $ readIO =<< readFile nameMapPath
liftIO $ putStrLn ("Downloading: " ++ show jsonUri)
jsonReq <- parseUrl jsonUri
jsonData <- responseBody <$> httpLbs jsonReq man
jsonDec <- either fail return (eitherDecode jsonData)
let namesMap = Map.fromList namesList
env = Env { envManager = man
, envLookupNames = (`Map.lookup` namesMap)
, envOutputDir = outputDir
}
mapM_ (downloadImage env) (jsonAuthors jsonDec)
_ -> liftIO $ do
name <- getProgName
hPutStrLn stderr . unlines
$ [ "USAGE: " ++ name ++ " <JSON-URI> <name-map-path> <output-dir>"
, ""
, "An example of JSON-URI: https://github.com/ekmett/lens/graphs/contributors-data"
]
exitFailure
jsonAuthors :: Value -> [Author]
jsonAuthors val =
[ Author (login ^. unpacked) (gravatar ^. unpacked)
| Object obj <- universeOf uniplate val
, String login <- obj ^.. ix "login"
, String gravatar <- obj ^.. ix "gravatar"
]
where
unpacked = from T.packed
downloadImage :: Env -> Author -> ResourceT IO ()
downloadImage (Env {..}) (Author {..}) =
case envLookupNames authorLogin of
Nothing ->
liftIO $ hPutStrLn stderr ("Unrecognized login: " ++ show authorLogin)
Just names -> do
liftIO $ putStrLn ("Downloading: " ++ show loginBase ++ ", " ++ show names)
req <- modImageReq <$> parseUrl authorImageURI
Response _ _ headers src <- http req envManager
suffix <-
case lookup hContentType headers of
Just "image/jpeg" -> return ".jpeg"
Just "image/png" -> return ".png"
t -> fail ("Unhandled Content-Type: " ++ show t)
let loginImage = loginBase ++ suffix
loginImageD = loginBaseD ++ suffix
loginImageTempD = loginImageD ++ tempSuffix
-- Download.
_ <- register $ unlinkIfExists loginImageTempD
src $$+- sinkFile loginImageTempD
liftIO $ do
unlinkIfExists loginImageD
rename loginImageTempD loginImageD
-- Delete potential old versions with other suffixes.
forM_ (delete suffix suffixes) $ \otherSuf -> do
unlinkIfExists (loginBaseD ++ otherSuf)
forM_ names $ \name -> unlinkIfExists (envOutputDir </> name ++ otherSuf)
-- Link names to the login.
forM_ names $ \name -> do
let nameD = envOutputDir </> name ++ suffix
unlinkIfExists nameD
createSymbolicLink loginImage nameD
where
loginBase = "github-" ++ authorLogin
loginBaseD = envOutputDir </> loginBase
suffixes = [".jpeg", ".png"]
tempSuffix = ".temp"
unlinkIfExists path =
removeLink path `catch` \(_ :: IOException) -> return ()
-- | Change/set the image size to 512 and the fallback image to identicon.
modImageReq :: Request m -> Request m
modImageReq req =
req & zipper
-- Request m :-> ByteString
& downward (lens queryString (\req' qs -> req' { queryString = qs }))
-- ByteString :<-> Map ByteString (Maybe ByteString)
& downward (iso parseQuery (renderQuery False) . wrapping Map.fromList)
& focus . at "s" ?~ Just "512"
& focus . at "d" ?~ Just "identicon"
& rezip
Something went wrong with that request. Please try again.