feed-translator 0.1.0.0 → 0.1.0.1
raw patch · 4 files changed
+316/−1 lines, 4 files
Files
- feed-translator.cabal +5/−1
- src/Web/Feed/FeedTranslator.hs +85/−0
- src/Web/Feed/FeedTranslatorView.hs +130/−0
- src/Web/Feed/FeedTranslatorWai.hs +96/−0
feed-translator.cabal view
@@ -1,7 +1,8 @@ name: feed-translator-version: 0.1.0.0+version: 0.1.0.1 synopsis: Translate syndication feeds homepage: https://github.com/dahlia/feed-translator+bug-reports: https://github.com/dahlia/feed-translator/issues license: AGPL-3 license-file: LICENSE author: Hong Minhee@@ -14,6 +15,9 @@ executable feed-translator main-is: Main.hs+ other-modules: Web.Feed.FeedTranslator,+ Web.Feed.FeedTranslatorView,+ Web.Feed.FeedTranslatorWai build-depends: base >=4.7 && <4.8, blaze-html >=0.8.0.0 && <0.9.0.0, blaze-markup >=0.7 && <0.8,
+ src/Web/Feed/FeedTranslator.hs view
@@ -0,0 +1,85 @@+module Web.Feed.FeedTranslator (Translator(..), translateFeed) where++import Control.Monad (liftM)+import Data.Text (Text, pack, unpack)+import Network.URI (URI, parseAbsoluteURI)+import Text.Feed.Constructor (withFeedItems, withFeedTitle, withItemDescription,+ withItemId, withItemLink, withItemTitle)+import Text.Feed.Types (Feed, Item)+import Text.Feed.Query (feedItems, getFeedTitle, getItemId, getItemDescription,+ getItemLink, getItemSummary, getItemTitle)++-- Text translator engine type.+type TextTranslator = Text -> IO Text++-- Link translator engine type.+type UrlTranslator = URI -> Maybe URI++-- Translator engine type combining 'TextTranslator' and 'UrlTranslator'.+data Translator = Translator { textTranslator :: TextTranslator+ , urlTranslator :: UrlTranslator+ }++-- | Translate the given feed.+translateFeed :: Translator -> Feed -> IO Feed+translateFeed translator feed = do+ let title :: Text+ title = pack $ getFeedTitle feed+ items :: [Item]+ items = feedItems feed+ translatedTitle <- textTranslator translator title+ translatedItems <- mapM (translateItem translator) items+ return $ withFeedItems translatedItems+ $ withFeedTitle (unpack translatedTitle) feed++-- | Translate a single item.+translateItem :: Translator -> Item -> IO Item+translateItem (Translator translate translateUrl) item = do+ let itemId :: Maybe (Bool, String)+ itemId = getItemId item+ desc :: Maybe String+ desc = case getItemDescription item of+ Nothing -> getItemSummary item+ Just "" -> getItemSummary item+ Just s -> Just s+ link :: Maybe String+ link = getItemLink item+ title :: Maybe String+ title = getItemTitle item+ tId :: Maybe String+ tId = case itemId of+ Just (True, id') -> Just $ translateLink id'+ Just (False, id') -> Just id'+ Nothing -> Nothing+ uri :: Bool+ uri = case itemId of+ Just (True, _) -> True+ _ -> False+ tLink :: Maybe String+ tLink = liftM translateLink link+ tTitle <- translate' title+ tDesc <- translate' desc+ let replace :: Item -> Item+ replace = setter tId (withItemId uri) .+ setter tLink withItemLink .+ setter tTitle withItemTitle .+ setter tDesc withItemDescription+ return $ replace item+ where+ translateLink :: String -> String+ translateLink urlString =+ case parseAbsoluteURI urlString of+ Just uri -> case translateUrl uri of+ Just translatedUri -> show translatedUri+ Nothing -> urlString+ Nothing -> urlString+ translate' :: Maybe String -> IO (Maybe String)+ translate' s =+ case s of+ Just s -> liftM (Just . unpack) $ translate $ pack s+ Nothing -> return Nothing+ setter :: Maybe a -> (a -> Item -> Item) -> Item -> Item+ setter value set =+ case value of+ Just value -> set value+ Nothing -> id
+ src/Web/Feed/FeedTranslatorView.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}+module Web.Feed.FeedTranslatorView (index) where++import Control.Monad (forM_)+import Data.List (intercalate)++import qualified Data.Map.Strict as M+import qualified Data.Set as S+import Text.Blaze (dataAttribute)+import Text.Blaze.Html (Html, toHtml)+import Text.Blaze.Html5+import Text.Blaze.Internal (AttributeValue, stringValue)+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as A+import Text.RawString.QQ++languagePairs :: M.Map String (S.Set String)+languagePairs = M.fromList [ ("en", S.fromList ["ko", "es", "pt", "id", "th"])+ , ("ko", S.fromList ["en", "ja"])+ , ("ja", S.fromList ["ko"])+ , ("es", S.fromList ["en"])+ , ("pt", S.fromList ["en"])+ , ("id", S.fromList ["en"])+ , ("th", S.fromList ["en"])+ ]++languageNames :: M.Map String String+languageNames = M.fromList [ ("en", "English")+ , ("ko", "한국어")+ , ("ja", "日本語")+ , ("es", "español")+ , ("pt", "português")+ , ("id", "Bahasa Indonesia")+ , ("th", "ไทย")+ ]++languageSelector :: AttributeValue -- | The 'name' of 'select' element.+ -> Html+languageSelector name' =+ select ! A.name name' ! A.id name' ! A.class_ "browser-default" $ do+ let langs = M.toList languageNames+ forM_ langs $ \(code, name') ->+ let targets = case M.lookup code languagePairs of+ Just set -> intercalate "," $ S.toList set+ Nothing -> ""+ opt = option ! A.value (stringValue code)+ ! dataAttribute "targets" (stringValue targets)+ in case targets of+ "" -> opt ! A.disabled "disabled"+ _ -> opt+ $ toHtml (name' ++ " [" ++ code ++ "]")++materializeCss :: AttributeValue+materializeCss = "//cdnjs.cloudflare.com/ajax/libs/materialize/0.97.0/css/materialize.min.css"++materializeJs :: AttributeValue+materializeJs = "//cdnjs.cloudflare.com/ajax/libs/materialize/0.97.0/js/materialize.min.js"++jQueryJs :: AttributeValue+jQueryJs = "//code.jquery.com/jquery-2.1.4.min.js"++index :: Html+index =+ docTypeHtml $ do+ H.head $ do+ meta ! A.charset "utf8"+ title "Feed Translator"+ link ! A.rel "stylesheet" ! A.href materializeCss+ body $ do+ nav $+ H.div ! A.class_ "container" $+ H.div ! A.class_ "nav-wrapper" $+ a ! A.class_ "brand-logo"+ ! A.href "/"+ $ "Feed Translator"+ H.div ! A.class_ "container" $ do+ p $ do+ "Powered by "+ a ! A.href "http://translate.naver.com/"+ $ "Naver Translate"+ "."+ form ! A.action "/query/" $ do+ H.div ! A.class_ "row" $ do+ H.div ! A.class_ "col s6" $ do+ H.div ! A.class_ "row" $+ H.div ! A.class_ "input-field col s12" $+ label ! A.for "source" $ "From"+ H.div ! A.class_ "row" $+ H.div ! A.class_ "input-field col s12" $+ languageSelector "source"+ H.div ! A.class_ "col s6" $ do+ H.div ! A.class_ "row" $+ H.div ! A.class_ "input-field col s12" $+ label ! A.for "target" $ "To"+ H.div ! A.class_ "row" $+ H.div ! A.class_ "input-field col s12" $+ languageSelector "target"+ H.div ! A.class_ "row" $+ H.div ! A.class_ "input-field col s12" $ do+ input ! A.id "url"+ ! A.name "url"+ ! A.type_ "url"+ ! A.class_ "validate"+ label ! A.for "url" $ "URL"+ H.div ! A.class_ "row" $+ H.div ! A.class_ "input-field col s12" $+ button ! A.type_ "submit"+ ! A.class_ "waves-effect waves-light btn"+ $ "Translate"+ script ! A.src jQueryJs $ ""+ script ! A.src materializeJs $ ""+ script [r|+ (function ($) {+ var filterTarget = function () {+ var sourceOption = $('option:selected', this);+ var dataTargets = sourceOption.data('targets') || '';+ var targets = dataTargets.split(',');+ $('select[name=target] > option').prop(+ 'disabled',+ function () {+ return targets.indexOf(this.value) < 0;+ }+ );+ $('select[name=target] > ' ++ 'option:not(:disabled):first').prop('selected', true);+ };+ var source = $('select[name=source]').change(filterTarget)+ .each(filterTarget);+ })(jQuery);+ |]
+ src/Web/Feed/FeedTranslatorWai.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE OverloadedStrings #-}+module Web.Feed.FeedTranslatorWai (application) where++import Data.Maybe (catMaybes, listToMaybe)+import Control.Monad (liftM)+import Control.Monad.IO.Class (liftIO)++import Control.Lens.Getter ((^.))+import Data.LanguageCodes (ISO639_1, fromChars)+import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import Data.Text.Encoding (decodeUtf8)+import qualified Data.Text.Lazy.Encoding as LTE+import Language.Translate.Naver (translate, translateUrl)+import Network.Wai (Application, rawQueryString)+import qualified Network.Wreq as W+import Text.Blaze.Html.Renderer.Text (renderHtml)+import Text.Feed.Types (Feed)+import Text.Feed.Export (xmlFeed)+import Text.Feed.Import (readAtom, readRSS1, readRSS2)+import Text.XML.Light.Input (parseXMLDoc)+import Text.XML.Light.Output (showElement)+import Web.Scotty (ActionM, get, html, next, param, params, raw, redirect,+ regex, request, scottyApp, setHeader)++import Web.Feed.FeedTranslator (Translator(..), translateFeed)+import Web.Feed.FeedTranslatorView (index)++-- | Return the Naver Translate engine that translates text from the+-- 'sourceLanguage' to 'targetLanguage'.+naverTranslator :: ISO639_1 -- | The language translated from+ -> ISO639_1 -- | The language to translate to+ -> Translator+naverTranslator sourceLanguage targetLanguage =+ Translator { textTranslator = translate sourceLanguage targetLanguage+ , urlTranslator = translateUrl sourceLanguage targetLanguage+ }++-- | Translate the feed of given 'url' using 'translator'.+translateFeedUrl :: Translator -- | The translator engine to use+ -> String -- | The feed url to translate+ -> IO Feed -- | The translated feed+translateFeedUrl translator url = do+ response <- W.get url+ case response ^. W.responseStatus . W.statusCode of+ 200 -> do+ let xmlString = LTE.decodeUtf8 $ response ^. W.responseBody+ xmlDoc = parseXMLDoc xmlString+ readers = [readAtom, readRSS2, readRSS1]+ possibleFeeds = catMaybes [read =<< xmlDoc | read <- readers]+ feed = listToMaybe possibleFeeds+ case feed of+ Just feed' -> translateFeed translator feed'+ Nothing ->+ ioError $ userError "failed to parse feed"+ _ -> ioError $ userError $ "bad request: " ++ url++parseLanguageCode :: ActionM LT.Text -> ActionM ISO639_1+parseLanguageCode code = do+ code' <- code+ case LT.unpack code' of+ [a, b] -> case fromChars a b of+ Just lang -> return lang+ Nothing -> next+ _ -> next++-- | WAI web application.+application :: IO Application+application = scottyApp $ do+ get "/" $+ html $ renderHtml index+ get "/query/" $ do+ source <- param "source"+ target <- param "target"+ url <- param "url"+ let getUrl scheme path = LT.concat [ "/", source, "/", target, "/"+ , scheme , "/", LT.drop 3 path+ ]+ case LT.breakOn "://" url of+ ("http", path) -> redirect $ getUrl "http" path+ ("https", path) -> redirect $ getUrl "https" path+ a -> redirect "/"+ get (regex "^/([a-z]{2})/([a-z]{2})/(http|https)/(.*)") $ do+ source <- parseLanguageCode $ param "1"+ target <- parseLanguageCode $ param "2"+ scheme <- liftM LT.toStrict $ param "3"+ path <- liftM LT.toStrict $ param "4"+ query <- liftM (decodeUtf8 . rawQueryString) request+ let url :: String+ url = T.unpack $ T.concat [scheme, "://", path, query]+ let translator = naverTranslator source target+ feed <- liftIO $ translateFeedUrl translator url+ let feedXml = LT.pack $ showElement $ xmlFeed feed+ setHeader "Content-Type" "text/xml; charset=utf8"+ raw $ LTE.encodeUtf8 feedXml