router.hs

{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings, ViewPatterns #-}

module Main where
  
  import Control.Applicative
  import Data.ByteString (ByteString)
  import qualified Data.ByteString as B
  import Data.Char
  import Data.Monoid
  import Data.Scotty
  
  -- future:
  -- bshow = B.pack . show
  
  -- class (Bounded a, Show a) => Parseable a where
  -- 
  -- allValues :: Bounded a => [a]
  -- allValues = [minBound..maxBound]
  -- 
  -- genParse :: Parseable a
  -- genParse = foldl1 (<|>) (map lcParser allValues) where
  --   foo :: a -> Parser a
  --   foo x = string (B.map toLower (bshow x))
  
  class Parseable a where
    parser :: Parser a
  
  instance (Parseable a, Parseable b) => Parseable (Either a b) where
    parser = (Left <$> (parse :: Parser a)) <|> (Right <$> (parse :: Parser b))
  
  parserRoute :: (Parseable a) => (a -> Maybe [Param]) -> RoutePattern
  parserRoute callback = function handler where
    handler (rawPathInfo -> path) = maybeResult (parse parser path) >>= callback

  data Xcode = Xcode deriving (Eq)
  instance Show Xcode where show = const "xcode"
  instance Parse Xcode where parse = Xcode <$ string "xcode"
  
  data Platform = OSX | IOS deriving (Eq)
  
  instance Show Platform where
    show OSX = "osx"
    show IOS = "ios"
  
  instance Parseable Platform where
    parse = (OSX <$ string "osx") <|> (IOS <$ string "ios")
  
  data SDK = SDK 
    { tool :: Either XCode Platform
    , train :: ByteString
    , build :: ByteString
    }
  
  slash = string "/"
  
  infixr 7 </>
  (</>) :: ByteString -> ByteString -> ByteString
  a </> b = a <> "/" <> b
  
  instance Show SDK where
    show SDK { tool, train, build } = B.unpack (tool </> train </> build)
  
  instance Parseable SDK where
    parser = SDK <$> (slash *> parse) <$> (slash *> parse) <$> (slash *> takeByteString)
  
  parseSDK :: Request -> Maybe [Param]
  parseEDK = const []
  
  main :: IO ()
  main = scotty 3000 $ do
    get (parserRoute parseSDK) $ \s->
      text ("SDK: " <> tool </> train </> build)
    
    notFound = text l where (Left l) = parseOnly (parse :: SDK)