Main.hs

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where


import qualified Data.ByteString as BS
import Data.Foldable (asum)
import qualified Data.Map as Map
import Data.Word (Word8)
import GHC.Conc
import qualified Snap.Core as S
import qualified Snap.Http.Server as S
import Snap.Util.FileServe (serveFile)
import System.Console.CmdArgs

import qualified Elm.ModuleName as ModuleName
import qualified Elm.Package as Pkg
import qualified Elm.Version as V
import qualified Json.Encode as E
import qualified Parse.Primitives as P

import qualified Artifacts
import qualified GitHub
import qualified Gzip
import qualified Legacy
import qualified Memory
import qualified Memory.History as History
import qualified Package.Path as Path
import qualified Package.Register as Register
import qualified Server.Router as Router
import Server.Router (Route, top, s, int, bytes, (</>), (==>))
import qualified ServeFile



-- FLAGS


data Flags =
  Flags
    { port :: Int
    , github :: String
    }
    deriving (Data,Typeable,Show,Eq)


flags :: Flags
flags =
  Flags
    { port = 8000
        &= help "set the port of the server"
    , github = ""
        &= help "OAuth token for talking to GitHub"
    }



-- MAIN


main :: IO ()
main =
  do  setNumCapabilities =<< getNumProcessors
      cargs <- cmdArgs flags

      artifacts <- Artifacts.init
      memory <- Memory.init
      token <- GitHub.init (github cargs)

      putStrLn $ "Serving at http://localhost:" ++ show (port cargs)
      S.httpServe (config (port cargs)) (serve artifacts token memory)


config :: Int -> S.Config S.Snap a
config port =
  S.defaultConfig
    # S.setVerbose False
    # S.setPort port
    # S.setAccessLog S.ConfigNoLog
    # S.setErrorLog S.ConfigNoLog


(#) :: a -> (a -> b) -> b
(#) value func =
  func value



-- SERVE


serve :: Artifacts.Artifacts -> GitHub.Token -> Memory.Memory -> S.Snap ()
serve artifacts token memory =
  asum
    [
      -- LEGACY USERS (<0.19)
      Legacy.getElmVersion >>= Legacy.serve
    ,
      -- NORMAL ROUTES
      Router.serve $ Router.oneOf $
        [ top ==> ServeFile.misc artifacts "Elm Packages"
        , s "packages" ==> S.redirect' "/" 301
        , s "packages" </> bytes </> bytes </> packageRoute ==> servePackageInfo artifacts memory
        , s "search.json" ==> Gzip.serveFile "application/json" "search.json.gz"
        , s "all-packages" ==> serveFile "all-packages.json"
        , s "all-packages" </> s "since" </> int ==> serveNewPackages memory
        , s "register" ==> Register.register token memory
        , s "artifacts" </> bytes ==> Artifacts.serve artifacts
        , s "assets" </> s "fonts.css" ==> serveFonts
        , s "help" </>
            Router.oneOf
              [ s "design-guidelines" ==> ServeFile.misc artifacts "Design Guidelines"
              , s "documentation-format" ==> ServeFile.misc artifacts "Documentation Format"
              ]
        ]
    ,
      -- NOT FOUND
      do  S.modifyResponse $ S.setResponseStatus 404 "Not Found"
          method <- S.getsRequest S.rqMethod
          if method == S.GET
            then ServeFile.misc artifacts "Not Found"
            else S.writeBuilder "Not Found"

    ]



-- NEW PACKAGES


serveNewPackages :: Memory.Memory -> Int -> S.Snap ()
serveNewPackages memory index =
  do  history <- Memory.getHistory memory
      S.writeBuilder $ E.encodeUgly $ E.list History.encodeEvent $
        History.since index history



-- PACKAGE ROUTE


data PackageRoute
  = PkgOverview
  | Pkg__releases_json
  | PkgVersion (Maybe V.Version) VsnRoute


packageRoute :: Route (PackageRoute -> a) a
packageRoute =
  Router.oneOf
    [ top                  ==> PkgOverview
    , s "releases.json"    ==> Pkg__releases_json
    , version </> vsnRoute ==> PkgVersion
    ]


version :: Route (Maybe V.Version -> a) a
version =
  Router.oneOf
    [ s "latest" ==> Nothing
    , Router.custom toVersion ==> Just
    ]


toVersion :: BS.ByteString -> Maybe V.Version
toVersion bytes =
  case P.fromByteString V.parser (,) bytes of
    Right vsn -> Just vsn
    Left _    -> Nothing



-- VERSION ROUTE


data VsnRoute
  = VsnOverview
  | VsnAbout
  | VsnModule ModuleName.Raw
  | Vsn__elm_json
  | Vsn__docs_json
  | Vsn__README_md
  | Vsn__endpoint_json


vsnRoute :: Route (VsnRoute -> a) a
vsnRoute =
  Router.oneOf
    [ top ==> VsnOverview
    , s "about" ==> VsnAbout
    , s "elm.json" ==> Vsn__elm_json
    , s "docs.json" ==> Vsn__docs_json
    , s "README.md" ==> Vsn__README_md
    , s "endpoint.json" ==> Vsn__endpoint_json
    , Router.custom toModuleName ==> VsnModule
    ]


toModuleName :: BS.ByteString -> Maybe ModuleName.Raw
toModuleName bytes =
  case P.fromByteString ModuleName.parser (,) (BS.map toDot bytes) of
    Right name -> Just name
    Left _     -> Nothing


toDot :: Word8 -> Word8
toDot word =
  if word == 0x2D {---}
  then 0x2E {-.-}
  else word



-- SERVE PACKAGE INFO


servePackageInfo :: Artifacts.Artifacts -> Memory.Memory -> BS.ByteString -> BS.ByteString -> PackageRoute -> S.Snap ()
servePackageInfo artifacts memory author project pkgRoute =
  case P.fromByteString Pkg.parser (,) (BS.concat [author,"/",project]) of
    Left _ ->
      S.pass

    Right pkg ->
      case pkgRoute of
        PkgOverview ->
          do  pkgs <- Memory.getPackages memory
              if Map.member pkg pkgs
                then ServeFile.project artifacts pkg
                else S.pass

        Pkg__releases_json ->
          serveFile (Path.releases pkg)

        PkgVersion maybeVersion vsnRoute ->
          serveVersion artifacts memory pkg maybeVersion vsnRoute


serveVersion :: Artifacts.Artifacts -> Memory.Memory -> Pkg.Name -> Maybe V.Version -> VsnRoute -> S.Snap ()
serveVersion artifacts memory pkg maybeVersion vsnRoute =
  do  pkgs <- Memory.getPackages memory
      case Map.lookup pkg pkgs of
        Nothing ->
          S.pass

        Just (Memory.Summary versions _ _) ->
          case verifyVersion maybeVersion versions of
            Nothing ->
              S.pass

            Just vsn ->
              case vsnRoute of
                VsnOverview        -> ServeFile.version artifacts pkg vsn Nothing
                VsnAbout           -> ServeFile.version artifacts pkg vsn Nothing
                Vsn__elm_json      -> Gzip.serveFile "application/json" (Path.directory pkg vsn ++ "/elm.json.gz")
                Vsn__docs_json     -> Gzip.serveFile "application/json" (Path.directory pkg vsn ++ "/docs.json.gz")
                Vsn__README_md     -> Gzip.serveFile "text/markdown; charset=UTF-8" (Path.directory pkg vsn ++ "/README.md.gz")
                Vsn__endpoint_json -> serveFile (Path.directory pkg vsn ++ "/endpoint.json")
                VsnModule name     -> ServeFile.version artifacts pkg vsn (Just name)


verifyVersion :: Maybe V.Version -> [V.Version] -> Maybe V.Version
verifyVersion maybeVersion versions =
  case versions of
    [] ->
      Nothing

    _:_ ->
      case maybeVersion of
        Nothing ->
          Just (maximum versions)

        Just version ->
          if elem version versions
          then Just version
          else Nothing



-- SERVE FONTS


serveFonts :: S.Snap ()
serveFonts =
  do  maybeHeader <- S.getsRequest (S.getHeader "User-Agent")
      case maybeHeader of
        Nothing ->
          return ()

        Just userAgent ->
          if BS.isInfixOf "Macintosh" userAgent
          then Gzip.serveFile "text/css" "assets/fonts/_hints_off.css.gz"
          else Gzip.serveFile "text/css" "assets/fonts/_hints_on.css.gz"