diff --git a/19-applying-structure/shawty-prime/LICENSE b/19-applying-structure/shawty-prime/LICENSE new file mode 100644 index 0000000..5728243 --- /dev/null +++ b/19-applying-structure/shawty-prime/LICENSE @@ -0,0 +1,30 @@ +Copyright Chris Allen (c) 2015 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Chris Allen nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/19-applying-structure/shawty-prime/Setup.hs b/19-applying-structure/shawty-prime/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/19-applying-structure/shawty-prime/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/19-applying-structure/shawty-prime/app/Main.hs b/19-applying-structure/shawty-prime/app/Main.hs new file mode 100644 index 0000000..c43e302 --- /dev/null +++ b/19-applying-structure/shawty-prime/app/Main.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Monad (replicateM) +import Control.Monad.IO.Class (liftIO) +import qualified Data.ByteString.Char8 as BC +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import qualified Data.Text.Lazy as TL +import qualified Database.Redis as R +import Network.URI (URI, parseURI) +import qualified System.Random as SR +import Web.Scotty + +alphaNum :: String +alphaNum = ['A'..'Z'] ++ ['0'..'9'] + +randomElement :: String -> IO Char +randomElement xs = do + let maxIndex :: Int + maxIndex = length xs - 1 + -- Right of arrow is IO Int, so randomDigit is Int + randomDigit <- SR.randomRIO (0, maxIndex) :: IO Int + return (xs !! randomDigit) + +shortyGen :: IO String +shortyGen = + replicateM 7 (randomElement alphaNum) + +saveURI :: R.Connection + -> BC.ByteString + -> BC.ByteString + -> IO (Either R.Reply R.Status) +saveURI conn shortURI uri = + R.runRedis conn $ R.set shortURI uri + +getURI :: R.Connection + -> BC.ByteString + -> IO (Either R.Reply (Maybe BC.ByteString)) +getURI conn shortURI = R.runRedis conn $ R.get shortURI + +linkShorty :: String -> String +linkShorty shorty = + concat [ "Copy and paste your short URL" + ] + +shortyCreated :: Show a => a -> String -> TL.Text +shortyCreated resp shawty = + TL.concat [ TL.pack (show resp) + , " shorty is: ", TL.pack (linkShorty shawty) + ] + +shortyAintUri :: TL.Text -> TL.Text +shortyAintUri uri = + TL.concat [ uri + , " wasn't a url, did you forget http://?" + ] + +shortyFound :: TL.Text -> TL.Text +shortyFound tbs = + TL.concat ["", tbs, ""] + +app :: R.Connection + -> ScottyM () +app rConn = do + get "/" $ do + uri <- param "uri" + let parsedUri :: Maybe URI + parsedUri = parseURI (TL.unpack uri) + case parsedUri of + Just _ -> do + shawty <- liftIO shortyGen + let shorty = BC.pack shawty + uri' = encodeUtf8 (TL.toStrict uri) + -- **** Excercise **** + -- Check if it already exists + uri'' <- liftIO (getURI rConn shorty) + case uri'' of + Left reply -> text (TL.pack (show reply)) + Right mbBS -> case mbBS of + Nothing -> do + -- It doesn't so save it + resp <- liftIO (saveURI rConn shorty uri') + html (shortyCreated resp shawty) + Just _ -> text "Duplicate short uri created." + -- **** End of Exercise **** + Nothing -> text (shortyAintUri uri) + get "/:short" $ do + short <- param "short" + uri <- liftIO (getURI rConn short) + case uri of + Left reply -> text (TL.pack (show reply)) + Right mbBS -> case mbBS of + Nothing -> text "uri not found" + Just bs -> html (shortyFound tbs) + where tbs :: TL.Text + tbs = TL.fromStrict (decodeUtf8 bs) + +main :: IO () +main = do + rConn <- R.connect R.defaultConnectInfo + scotty 3000 (app rConn) diff --git a/19-applying-structure/shawty-prime/shawty.cabal b/19-applying-structure/shawty-prime/shawty.cabal new file mode 100644 index 0000000..44ff1ef --- /dev/null +++ b/19-applying-structure/shawty-prime/shawty.cabal @@ -0,0 +1,33 @@ +name: shawty +version: 0.1.0.0 +synopsis: Initial project template from stack +description: Please see README.md +homepage: http://github.com/bitemyapp/shawty#readme +license: BSD3 +license-file: LICENSE +author: Chris Allen +maintainer: cma@bitemyapp.com +copyright: 2015, Chris Allen +category: Web +build-type: Simple +cabal-version: >=1.10 + +executable shawty + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , bytestring + , hedis + , mtl + , network-uri + , random + , scotty + , semigroups + , text + , transformers + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/bitemyapp/shawty-prime diff --git a/19-applying-structure/shawty-prime/stack.yaml b/19-applying-structure/shawty-prime/stack.yaml new file mode 100644 index 0000000..2e43058 --- /dev/null +++ b/19-applying-structure/shawty-prime/stack.yaml @@ -0,0 +1,32 @@ +# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md + +# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) +resolver: lts-3.7 + +# Local packages, usually specified by relative directory name +packages: +- '.' + +# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) +extra-deps: [] + +# Override default flag values for local packages and extra-deps +flags: {} + +# Extra package databases containing global packages +extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true + +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: >= 0.1.4.0 + +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 + +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir]